!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This file contains a library of various useful functions
! that are employed to conduct the necessary calculations.
! See the comments for each function for attribution and
! details.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!



    module tools

    contains


    integer function locate(x, xgrid)

    implicit none

    integer :: n, ju, jm, jl, jndx
    real(8), intent(in) :: x, xgrid(:)

    n = size(xgrid)
    jl = 0
    ju = n+1
    do while (ju-jl > 1)
        jm = (ju + jl)/2
        if (x >= xgrid(jm)) then
            jl = jm
        else
            ju = jm
        end if
    end do

    if (x == xgrid(1)) then
        jndx = 1
    else if (x == xgrid(n)) then
        jndx = n-1
    else
        jndx = jl
    end if

    locate = jndx

    end function



    subroutine quadnorm(theta, rho, sigma, n, y, t, w)
    !=============================================================

    ! ============================================================
    ! PURPOSE:  This program is designed to construct the grid and !
    !           transition matrix following the Tauchen and Hussey !
    !           approximations for an AR(1) process.  This will    !
    !           be used for numeric intergration in the calculation!
    !           of various value functions.  This will take as an  !
    !           input various parameters of the specification.     !
    ! ============================================================
    ! INPUTS:                                                      !
    !           theta - constant term in AR(1) equation            !
    !           rho   - auto-regressive term in AR(1) equation     !
    !           sigma - conditional variance in AR(1) equation     !
    !           n     - number of grid points to intergrate over   !
    !                                                              !
    ! OUTPUTS:                                                     !
    !           y     - grid points for continuous variable        !
    !           T     - transition matrix over grid points         !
    !           w     - weighting function for grid points         !
    ! ============================================================


    implicit none
    integer, intent(in) :: n
    real(8), intent(in) :: theta, rho, sigma
    real(8), intent(out) :: y(n,1), t(n,n), w(n,1)
    real(8),parameter :: pi = 3.141592653589793238462643383279502884197

    integer :: iteration, i, j, ii, jj

    real(8) :: t1(n), x(n,1), t2(n,n)

    !!! Calculate Gauss Hermite grid and weight
    iteration=20000                     !!! Maximum iterations

    call ghquad(n,iteration,x,w)        !!! routine to find Gauss Hermite grid and weight

    y=sqrt(2.0)*sigma*x+theta/(1.0-rho) !!! Calculate corresponding y

    !!! Calculate transition matrix
    t=0.0
    do i=1,n !! (t)
        do j=1,n  !! (t+1)
            t(i,j)=exp(-(y(j,1)-theta-rho*y(i,1))**2.0/(2.0*sigma**2.0) &
                +(y(j,1)-theta/(1.0-rho))**2.0/(2.0*sigma**2.0))*(1.0/pi)**0.5*w(j,1)
        end do
    end do

    !! Normalize each row
    t1 = sum(t,2)

    do ii=1,n
        do jj=1,n
            t2(ii,jj) = t(ii,jj)/t1(ii)
        end do
    end do

    t=transpose(t2)



    end subroutine quadnorm


    subroutine ghquad(n,maxit,x,w)
    ! Adapted from: Press, et al. Numerical Recipes in Fortran, 2nd ed.
    ! Returns the abscissas (x) and weights (w) for Gauss-Hermite
    ! quadrature of order n.
    ! This is used to compute integrals of the form
    !    int(exp(-x**2)f(x))
    ! over the whole real line.
    ! The integral is computed as w'f(x)
    ! The integration will be exact for any polynomial f(x) of order
    ! less than 2n. maxit - maximum iteratioins.
    ! Example:
    !   To compute the integral of the function exp(-x**2)(x**4+10) use:
    !   [x,w]=ghquad(3)
    !   int=w'(x**4+10)
    !
    ! To convert these abscissas and weights to those appropriate for
    ! computing moments of the standard normal distribution
    ! multiply the abscissas by sqrt(2) and divide the weights by
    ! sqrt(pi).


    implicit none

    integer, intent(in) :: maxit
    integer, intent(in) :: n
    real(8), intent(out) :: x(n,1), w(n,1)

    real(8),parameter :: pi = 3.141592653589793238462643383279502884197
    real(8) :: tol, pim4, z, z1, p1, p2, p3, pp, pdist, xtemp(n,1)
    integer :: m, i, j, its


    tol=100
    pim4=1.0/pi**0.25
    m=int((n+1)/2)
    x=0.0
    w=x

    do i = 1,m
        if (i==1) then
            z=sqrt(2.0*n+1.0)-1.85575*((2.0*n+1.0)**(-1.0/6.0))
        elseif (i==2) then
            z=z-1.14*(n**0.426)/z
        elseif (i==3) then
            z=1.86*z-0.86*x(1,1)
        elseif (i==4) then
            z=1.91*z-0.91*x(2,1)
        else
            z=2.0*z-x(i-2,1)
        end if

        its = 0
        convergeloop: do
            its = its + 1
            p1=pim4
            p2=0.0
            do j=1,n
                p3=p2
                p2=p1
                p1=z*sqrt(2.0/j)*p2-sqrt((j-1.0)/j)*p3
            enddo
            pp=sqrt(2.0*n)*p2
            z1=z
            z=z1-p1/pp
            pdist = abs(z-z1)

            if (pdist<1e-14 .or. its > maxit) exit convergeloop

        enddo  convergeloop
        if (its>=maxit) write(*,*) "Exceeded allowable iterations in finding root"

        x(n+1-i,1)=-z
        x(i,1)=z
        w(i,1)=2/(pp*pp)
        w(n+1-i,1)=w(i,1)
    enddo

    ! xtemp = 0.0
    ! do i=1,n
    !   xtemp(i,1) = x(n-i+1,1)
    ! enddo
    ! x=xtemp
    end subroutine ghquad


    subroutine markov(a,s2,nn,m,mu,mumid,trans,z)


    implicit none

    real(8), intent(in) :: a, s2, m,mu,mumid
    integer, intent(in) :: nn
    real(8), intent(out), dimension(1:nn) :: z
    real(8), intent(out), dimension(1:nn,1:nn) :: trans

    real(8) :: sy, s, w, f1(1:nn,1:nn), f2(1:nn,1:nn), minif,DNORDF
    integer :: ii, jj

    f1 = 0d0
    f2 = 1d0

    z = 0d0
    trans = 0d0

    sy = sqrt(s2/(1d0-a**2d0))

    do ii=1,nn
        z(ii) = mumid-m*sy + ((2d0*m*sy)/(real(nn)-1d0))*(real(ii)-1d0)
    enddo

    s = sqrt(s2)
    w = z(2) - z(1)

    do jj=1,nn
        do ii=2,nn
            minif = (z(ii)-a*z(jj)-w/2d0-mu)/s

            !	 f1(ii,jj)=DNORDF(minif)
            ! f2(ii-1,jj)=DNORDF(minif)
            f1(ii,jj)   = 0.5*(1d0 + derf(minif/sqrt(2d0)))
            f2(ii-1,jj) = 0.5*(1d0 + derf(minif/sqrt(2d0)))
        enddo

    enddo

    f1 = transpose(f1)
    f2 = transpose(f2)

    trans = f2 - f1

    return
    end subroutine markov


    subroutine markov_feed(a,s2,nn,m,mu,mumid,trans)


    implicit none

    real(8), intent(in) :: a, s2, mu,mumid
    real(8), intent(in), dimension(1:nn) :: m
    integer, intent(in) :: nn
    real(8), dimension(1:nn) :: z
    real(8), intent(out), dimension(1:nn,1:nn) :: trans

    real(8) :: sy, s, w, f1(1:nn,1:nn), f2(1:nn,1:nn), minif,DNORDF
    integer :: ii, jj

    f1 = 0d0
    f2 = 1d0

    z = 0d0
    trans = 0d0

    sy = sqrt(s2/(1d0-a**2d0))


    z=m


    s = sqrt(s2)
    w = z(2) - z(1)

    do jj=1,nn
        do ii=2,nn
            minif = (z(ii)-a*z(jj)-w/2d0-mu)/s


            f1(ii,jj)   = 0.5*(1d0 + derf(minif/sqrt(2d0)))
            f2(ii-1,jj) = 0.5*(1d0 + derf(minif/sqrt(2d0)))
        enddo

    enddo

    f1 = transpose(f1)
    f2 = transpose(f2)

    trans = f2 - f1

    return
    end subroutine markov_feed


    function norm_rand(mean, std_dev)
    real*8 :: norm_rand
    real*8, intent(in) :: mean, std_dev
    real*8 :: x, y, r
    real*8, save :: spare
    logical, save :: has_spare
    ! use a spare saved from a previous run if one exists
    if (has_spare) then
        has_spare = .FALSE.
        norm_rand = mean + (std_dev * spare)
        return
    else
        r = 1.0
        do while ( r >= 1.0 )
            ! generate random number pair between 0 and 1
            call random_number(x)
            call random_number(y)
            ! normalise random numbers to be in square of side-length = R
            x = (x * 2.0) - 1.0
            y = (y * 2.0) - 1.0
            r = x*x + y*y
        end do

        ! calculate the co-efficient to multiply random numbers x and y
        ! by to achieve normal distribution
        r = sqrt((-2.0 * log(r)) / r)

        norm_rand = mean + (std_dev * x * r)
        spare = y * r
        has_spare = .FALSE.
        return
    end if
    end function norm_rand






    SUBROUTINE KRON(K, A, B)
    IMPLICIT NONE
    REAL(8), INTENT(IN)  :: A(:,:), B(:,:)
    REAL(8), INTENT(INOUT) :: K(:,:)
    INTEGER :: I, J, MA, NA, MB, NB
    MA = UBOUND(A, 1)
    NA = UBOUND(A, 2)
    MB = UBOUND(B, 1)
    NB = UBOUND(B, 2)
    IF (SIZE(K,1) /= MA*MB .OR. SIZE(K,2) /= NA*NB) THEN
        WRITE(*,*) 'K has invalid size'
        CALL ABORT
    END IF
    FORALL(I=1:MA, J=1:NA)
        K(MB*(I-1)+1:MB*I,NB*(J-1)+1:NB*J) = A(I,J)*B
    END FORALL
    END SUBROUTINE KRON

    SUBROUTINE Mean(vector,nvec,average)
    !---------------------------------------------------
    ! Subroutine to compute average of the elemets of a
    ! vector
    ! Input: - vector
    !		 - nvec: vector length
    ! Output: - average
    !---------------------------------------------------

    IMPLICIT NONE
    INTEGER*8, INTENT(IN) :: nvec
    REAL*8, DIMENSION(nvec),INTENT(IN) :: vector
    REAL*8 :: average

    average=SUM(vector)/nvec

    END SUBROUTINE Mean
    !---------------------------------------------------
    !---------------------------------------------------

    SUBROUTINE Std(vector,nvec,stdev)
    !---------------------------------------------------
    ! Subroutine to compute standard deviation of the
    ! elements of a vector
    ! Input: - vector
    !		 - nvec: vector length
    ! Output: - stdev
    !---------------------------------------------------

    IMPLICIT NONE
    INTEGER*8, INTENT(IN) :: nvec
    REAL*8, DIMENSION(nvec), INTENT(IN) :: vector
    REAL*8 :: variance,stdev, average

    CALL Mean(vector,nvec,average)
    variance=(SUM((vector-average)**2))/real(nvec)
    stdev=SQRT(variance)

    END SUBROUTINE Std
    !---------------------------------------------------



    SUBROUTINE Stds(vector,nvec,stdev)
    !---------------------------------------------------
    ! Subroutine to compute standard deviation of the
    ! elements of a vector
    ! Input: - vector
    !		 - nvec: vector length
    ! Output: - stdev
    !---------------------------------------------------

    IMPLICIT NONE
    INTEGER*8, INTENT(IN) :: nvec
    REAL*8, DIMENSION(nvec), INTENT(IN) :: vector
    REAL*8 :: variance,stdev, average

    CALL Mean(vector,nvec,average)
    variance=(SUM((vector-average)**2))/(nvec-1)
    stdev=SQRT(variance)

    END SUBROUTINE Stds
    !---------------------------------------------------

    subroutine coefcorr(x,y,n,rho)


    implicit none
    integer, intent(in) :: n
    real(8), intent(in) :: x(n),y(n)
    real(8), intent(out) :: rho
    real(8) :: vx, vy, vxy


    vx = sum(x**2.0)/real(n) - (sum(x)/real(n))**2.0
    vy = sum(y**2.0)/real(n) - (sum(y)/real(n))**2.0
    vxy = sum(x*y)/real(n) - (sum(y)/real(n))*(sum(x)/real(n))

    rho = vxy/sqrt(vx*vy)

    end subroutine coefcorr



    subroutine coefcorr2(x,y,n,rho)


    implicit none
    integer, intent(in) :: n
    real(8), intent(in) :: x(n),y(n)
    real(8), intent(out) :: rho
    real(8) :: vx, vy, vxy


    vx = sum(x**2.0)/real(n) - (sum(x)/real(n))**2.0
    vy = sum(y**2.0)/real(n) - (sum(y)/real(n))**2.0
    vxy = sum(x*y)/real(n) - (sum(y)/real(n))*(sum(x)/real(n))

    rho = vxy /vy

    end subroutine coefcorr2
    !------------------------------------------------------


    subroutine ar1(why,t,rho)
    implicit none
    integer, intent(in) :: t
    real(8), intent(in) :: why(t)
    real(8), intent(out) :: rho
    real(8) :: yt0(t-1),yt1(t-1),my0,my1,vy1,cov01

    yt0 = why(2:t)
    yt1 = why(1:t-1)

    my0 = sum(yt0)/(t-1)
    my1 = sum(yt1)/(t-1)

    vy1 = sum(yt1*yt1)/(t-1) - my1**2.0
    cov01 = sum(yt1*yt0)/(t-1) - my1*my0
    if (vy1 < 1.0d-12) then
        rho = 1.0
    else
        rho = cov01/vy1
    endif

    end subroutine ar1




    end module tools


    SUBROUTINE SSORT(X, Y, N, KFLAG)
    !C***BEGIN PROLOGUE  SSORT
    !C***PURPOSE  Sort an array and optionally make the same interchanges in
    !C            an auxiliary array.  The array may be sorted in increasing
    !C            or decreasing order.  A slightly modified QUICKSORT
    !C            algorithm is used.
    !C***LIBRARY   SLATEC
    !C***CATEGORY  N6A2B
    !C***TYPE      SINGLE PRECISION (SSORT-S, DSORT-D, ISORT-I)
    !C***KEYWORDS  SINGLETON QUICKSORT, SORT, SORTING
    !C***AUTHOR  Jones, R. E., (SNLA)
    !C           Wisniewski, J. A., (SNLA)
    !C***DESCRIPTION
    !C
    !C   SSORT sorts array X and optionally makes the same interchanges in
    !C   array Y.  The array X may be sorted in increasing order or
    !C   decreasing order.  A slightly modified quicksort algorithm is used.
    !C
    !C   Description of Parameters
    !C      X - array of values to be sorted   (usually abscissas)
    !C      Y - array to be (optionally) carried along
    !C      N - number of values in array X to be sorted
    !C      KFLAG - control parameter
    !C            =  2  means sort X in increasing order and carry Y along.
    !C            =  1  means sort X in increasing order (ignoring Y)
    !C            = -1  means sort X in decreasing order (ignoring Y)
    !C            = -2  means sort X in decreasing order and carry Y along.
    !C
    !C***REFERENCES  R. C. Singleton, Algorithm 347, An efficient algorithm
    !C                 for sorting with minimal storage, Communications of
    !C                 the ACM, 12, 3 (1969), pp. 185-187.
    !***REVISION HISTORY  (YYMMDD)
    !   761101  DATE WRITTEN
    !   761118  Modified to use the Singleton quicksort algorithm.  (JAW)
    !   890531  Changed all specific intrinsics to generic.  (WRB)
    !   890831  Modified array declarations.  (WRB)
    !   891009  Removed unreferenced statement labels.  (WRB)
    !   891024  Changed category.  (WRB)
    !   891024  REVISION DATE from Version 3.2
    !   891214  Prologue converted to Version 4.0 format.  (BAB)
    !   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
    !   901012  Declared all variables; changed X,Y to SX,SY. (M. McClain)
    !   920501  Reformatted the REFERENCES section.  (DWL, WRB)
    !   920519  Clarified error messages.  (DWL)
    !   920801  Declarations section rebuilt and code restructured to use
    !C           IF-THEN-ELSE-ENDIF.  (RWC, WRB)
    !***END PROLOGUE  SSORT
    !     .. Scalar Arguments ..
    INTEGER KFLAG, N
    !     .. Array Arguments ..
    REAL*8:: X(*), Y(*)
    !     .. Local Scalars ..
    REAL*8:: R, T, TT, TTY, TY
    INTEGER I, IJ, J, K, KK, L, M, NN
    !     .. Local Arrays ..
    INTEGER IL(21), IU(21)
    !     .. External Subroutines ..
    !     None
    !     .. Intrinsic Functions ..
    INTRINSIC ABS, INT
    !C***FIRST EXECUTABLE STATEMENT  SSORT
    NN = N
    IF (NN < 1) THEN
        PRINT *,   'The number of values to be sorted is not positive.'
        RETURN
    ENDIF
    !
    KK = ABS(KFLAG)
    IF (KK/=1 .AND. KK/=2) THEN
        PRINT *,'The sort control parameter, K, is not 2, 1, -1,or -2.'
        RETURN
    ENDIF
    !
    !     Alter array X to get decreasing order if needed
    !
    IF (KFLAG <= -1) THEN
        DO 10 I=1,NN
            X(I) = -X(I)
10      CONTINUE
    ENDIF
    !
    IF (KK == 2) GO TO 100
    !
    !     Sort X only
    !
    M = 1
    I = 1
    J = NN
    R = 0.375E0
    !
20  IF (I == J) GO TO 60
    IF (R <= 0.5898437E0) THEN
        R = R+3.90625E-2
    ELSE
        R = R-0.21875E0
    ENDIF
    !
30  K = I
    !
    !     Select a central element of the array and save it in location T
    !
    IJ = I + INT((J-I)*R)
    T = X(IJ)
    !
    !     If first element of array is greater than T, interchange with T
    !
    IF (X(I) > T) THEN
        X(IJ) = X(I)
        X(I) = T
        T = X(IJ)
    ENDIF
    L = J
    !
    !     If last element of array is less than than T, interchange with T
    !
    IF (X(J) < T) THEN
        X(IJ) = X(J)
        X(J) = T
        T = X(IJ)
        !
        !        If first element of array is greater than T, interchange with T
        !
        IF (X(I) > T) THEN
            X(IJ) = X(I)
            X(I) = T
            T = X(IJ)
        ENDIF
    ENDIF
    !
    !     Find an element in the second half of the array which is smaller
    !     than T
    !
40  L = L-1
    IF (X(L) > T) GO TO 40
    !
    !     Find an element in the first half of the array which is greater
    !     than T
    !
50  K = K+1
    IF (X(K) < T) GO TO 50
    !
    !     Interchange these elements
    !
    IF (K <= L) THEN
        TT = X(L)
        X(L) = X(K)
        X(K) = TT
        GO TO 40
    ENDIF
    !
    !     Save upper and lower subscripts of the array yet to be sorted
    !
    IF (L-I > J-K) THEN
        IL(M) = I
        IU(M) = L
        I = K
        M = M+1
    ELSE
        IL(M) = K
        IU(M) = J
        J = L
        M = M+1
    ENDIF
    GO TO 70
    !
    !     Begin again on another portion of the unsorted array
    !
60  M = M-1
    IF (M == 0) GO TO 190
    I = IL(M)
    J = IU(M)
    !
70  IF (J-I >= 1) GO TO 30
    IF (I == 1) GO TO 20
    I = I-1
    !
80  I = I+1
    IF (I == J) GO TO 60
    T = X(I+1)
    IF (X(I) <= T) GO TO 80
    K = I
    !
90  X(K+1) = X(K)
    K = K-1
    IF (T < X(K)) GO TO 90
    X(K+1) = T
    GO TO 80
    !
    !     Sort X and carry Y along
    !
100 M = 1
    I = 1
    J = NN
    R = 0.375E0
    !
110 IF (I == J) GO TO 150
    IF (R <= 0.5898437E0) THEN
        R = R+3.90625E-2
    ELSE
        R = R-0.21875E0
    ENDIF
    !
120 K = I
    !
    !     Select a central element of the array and save it in location T
    !
    IJ = I + INT((J-I)*R)
    T = X(IJ)
    TY = Y(IJ)
    !
    !     If first element of array is greater than T, interchange with T
    !
    IF (X(I) > T) THEN
        X(IJ) = X(I)
        X(I) = T
        T = X(IJ)
        Y(IJ) = Y(I)
        Y(I) = TY
        TY = Y(IJ)
    ENDIF
    L = J
    !
    !     If last element of array is less than T, interchange with T
    !
    IF (X(J) < T) THEN
        X(IJ) = X(J)
        X(J) = T
        T = X(IJ)
        Y(IJ) = Y(J)
        Y(J) = TY
        TY = Y(IJ)
        !
        !        If first element of array is greater than T, interchange with T
        !
        IF (X(I) > T) THEN
            X(IJ) = X(I)
            X(I) = T
            T = X(IJ)
            Y(IJ) = Y(I)
            Y(I) = TY
            TY = Y(IJ)
        ENDIF
    ENDIF
    !
    !     Find an element in the second half of the array which is smaller
    !     than T
    !
130 L = L-1
    IF (X(L) > T) GO TO 130
    !
    !     Find an element in the first half of the array which is greater
    !     than T
    !
140 K = K+1
    IF (X(K) < T) GO TO 140
    !
    !     Interchange these elements
    !
    IF (K <= L) THEN
        TT = X(L)
        X(L) = X(K)
        X(K) = TT
        TTY = Y(L)
        Y(L) = Y(K)
        Y(K) = TTY
        GO TO 130
    ENDIF
    !
    !     Save upper and lower subscripts of the array yet to be sorted
    !
    IF (L-I > J-K) THEN
        IL(M) = I
        IU(M) = L
        I = K
        M = M+1
    ELSE
        IL(M) = K
        IU(M) = J
        J = L
        M = M+1
    ENDIF
    GO TO 160
    !
    !     Begin again on another portion of the unsorted array
    !
150 M = M-1
    IF (M == 0) GO TO 190
    I = IL(M)
    J = IU(M)
    !
160 IF (J-I >= 1) GO TO 120
    IF (I == 1) GO TO 110
    I = I-1
    !
170 I = I+1
    IF (I == J) GO TO 150
    T = X(I+1)
    TY = Y(I+1)
    IF (X(I) <= T) GO TO 170
    K = I
    !
180 X(K+1) = X(K)
    Y(K+1) = Y(K)
    K = K-1
    IF (T < X(K)) GO TO 180
    X(K+1) = T
    Y(K+1) = TY
    GO TO 170
    !
    !     Clean up
    !
190 IF (KFLAG <= -1) THEN
        DO 200 I=1,NN
            X(I) = -X(I)
200     CONTINUE
    ENDIF
    RETURN
    END




    function c4_normal_01 ( seed )

    !*****************************************************************************80
    !
    !! C4_NORMAL_01 returns a unit pseudonormal C4.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    31 May 2007
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) SEED, a seed for the random
    !    number generator.
    !
    !    Output, complex ( kind = 4 ) C4_NORMAL_01, a unit pseudonormal value.
    !
    implicit none

    complex ( kind = 4 ) c4_normal_01
    real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
    real ( kind = 4 ) r4_uniform_01
    integer ( kind = 4 ) seed
    real ( kind = 4 ) v1
    real ( kind = 4 ) v2
    real ( kind = 4 ) x_c
    real ( kind = 4 ) x_r

    v1 = r4_uniform_01 ( seed )
    v2 = r4_uniform_01 ( seed )

    x_r = sqrt ( - 2.0E+00 * log ( v1 ) ) * cos ( 2.0E+00 * r4_pi * v2 )
    x_c = sqrt ( - 2.0E+00 * log ( v1 ) ) * sin ( 2.0E+00 * r4_pi * v2 )

    c4_normal_01 = cmplx ( x_r, x_c )

    return
    end
    function c8_normal_01 ( seed )

    !*****************************************************************************80
    !
    !! C8_NORMAL_01 returns a unit pseudonormal C8.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    31 May 2007
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) SEED, a seed for the random number
    !    generator.
    !
    !    Output, complex ( kind = 8 ) C8_NORMAL_01, a sample of the PDF.
    !
    !    Output, integer ( kind = 4 ) SEED, a seed for the random number
    !    generator.
    !
    implicit none

    complex ( kind = 8 ) c8_normal_01
    real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
    real ( kind = 8 ) r8_uniform_01
    integer ( kind = 4 ) seed
    real ( kind = 8 ) v1
    real ( kind = 8 ) v2
    real ( kind = 8 ) x_c
    real ( kind = 8 ) x_r

    v1 = r8_uniform_01 ( seed )
    v2 = r8_uniform_01 ( seed )

    x_r = sqrt ( - 2.0D+00 * log ( v1 ) ) * cos ( 2.0D+00 * r8_pi * v2 )
    x_c = sqrt ( - 2.0D+00 * log ( v1 ) ) * sin ( 2.0D+00 * r8_pi * v2 )

    c8_normal_01 = cmplx ( x_r, x_c, kind = 8 )

    return
    end
    function i4_normal_ab ( a, b, seed )

    !*****************************************************************************80
    !
    !! I4_NORMAL_AB returns a scaled pseudonormal I4.
    !
    !  Discussion:
    !
    !    The normal probability distribution function (PDF) is sampled,
    !    with mean A and standard deviation B.
    !
    !    The result is then rounded to the nearest integer.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    06 August 2013
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input, real ( kind = 4 ) A, the mean of the PDF.
    !
    !    Input, real ( kind = 4 ) B, the standard deviation of the PDF.
    !
    !    Input/output, integer ( kind = 4 ) SEED, a seed for the
    !    random number generator.
    !
    !    Output, integer ( kind = 4 ) I4_NORMAL_AB, a sample of the normal PDF.
    !
    implicit none

    real ( kind = 4 ) a
    real ( kind = 4 ) b
    integer ( kind = 4 ) i4_normal_ab
    real ( kind = 4 ) r1
    real ( kind = 4 ) r2
    real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
    real ( kind = 4 ) r4_uniform_01
    integer ( kind = 4 ) seed
    real ( kind = 4 ) x

    r1 = r4_uniform_01 ( seed )
    r2 = r4_uniform_01 ( seed )
    x = sqrt ( - 2.0E+00 * log ( r1 ) ) * cos ( 2.0E+00 * r4_pi * r2 )

    i4_normal_ab = nint ( a + b * x )

    return
    end
    function i8_normal_ab ( a, b, seed )

    !*****************************************************************************80
    !
    !! I8_NORMAL_AB returns a scaled pseudonormal I8.
    !
    !  Discussion:
    !
    !    The normal probability distribution function (PDF) is sampled,
    !    with mean A and standard deviation B.
    !
    !    The result is then rounded to the nearest integer.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    06 August 2013
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, the mean of the PDF.
    !
    !    Input, real ( kind = 8 ) B, the standard deviation of the PDF.
    !
    !    Input/output, integer ( kind = 8 ) SEED, a seed for the
    !    random number generator.
    !
    !    Output, integer ( kind = 8 ) I8_NORMAL_AB, a sample of the normal PDF.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) b
    integer ( kind = 8 ) i8_normal_ab
    real ( kind = 8 ) r1
    real ( kind = 8 ) r2
    real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
    real ( kind = 8 ) r8_uniform_01
    integer ( kind = 8 ) seed
    real ( kind = 8 ) x

    r1 = r8_uniform_01 ( seed )
    r2 = r8_uniform_01 ( seed )
    x = sqrt ( - 2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * r8_pi * r2 )

    i8_normal_ab = nint ( a + b * x )

    return
    end
    function r4_normal_01 ( seed )

    !*****************************************************************************80
    !
    !! R4_NORMAL_01 returns a unit pseudonormal R4.
    !
    !  Discussion:
    !
    !    The standard normal probability distribution function (PDF) has
    !    mean 0 and standard deviation 1.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    06 August 2013
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) SEED, a seed for the random
    !    number generator.
    !
    !    Output, real ( kind = 4 ) R4_NORMAL_01, a sample of the standard
    !    normal PDF.
    !
    implicit none

    real ( kind = 4 ) r1
    real ( kind = 4 ) r2
    real ( kind = 4 ) r4_normal_01
    real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
    real ( kind = 4 ) r4_uniform_01
    integer ( kind = 4 ) seed
    real ( kind = 4 ) x

    r1 = r4_uniform_01 ( seed )
    r2 = r4_uniform_01 ( seed )
    x = sqrt ( - 2.0E+00 * log ( r1 ) ) * cos ( 2.0E+00 * r4_pi * r2 )

    r4_normal_01 = x

    return
    end
    function r4_normal_ab ( a, b, seed )

    !*****************************************************************************80
    !
    !! R4_NORMAL_AB returns a scaled pseudonormal R4.
    !
    !  Discussion:
    !
    !    The normal probability distribution function (PDF) is sampled,
    !    with mean A and standard deviation B.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    06 August 2013
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input, real ( kind = 4 ) A, the mean of the PDF.
    !
    !    Input, real ( kind = 4 ) B, the standard deviation of the PDF.
    !
    !    Input/output, integer ( kind = 4 ) SEED, a seed for the random
    !    number generator.
    !
    !    Output, real ( kind = 4 ) R4_NORMAL_AB, a sample of the normal PDF.
    !
    implicit none

    real ( kind = 4 ) a
    real ( kind = 4 ) b
    real ( kind = 4 ) r1
    real ( kind = 4 ) r2
    real ( kind = 4 ) r4_normal_ab
    real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
    real ( kind = 4 ) r4_uniform_01
    integer ( kind = 4 ) seed
    real ( kind = 4 ) x

    r1 = r4_uniform_01 ( seed )
    r2 = r4_uniform_01 ( seed )
    x = sqrt ( - 2.0E+00 * log ( r1 ) ) * cos ( 2.0E+00 * r4_pi * r2 )

    r4_normal_ab = a + b * x

    return
    end
    function r4_uniform_01 ( seed )

    !*****************************************************************************80
    !
    !! R4_UNIFORM_01 returns a unit pseudorandom R4.
    !
    !  Discussion:
    !
    !    An R4 is a real ( kind = 4 ) value.
    !
    !    This routine implements the recursion
    !
    !      seed = 16807 * seed mod ( 2^31 - 1 )
    !      r4_uniform_01 = seed / ( 2^31 - 1 )
    !
    !    The integer arithmetic never requires more than 32 bits,
    !    including a sign bit.
    !
    !    If the initial seed is 12345, then the first three computations are
    !
    !      Input     Output      R4_UNIFORM_01
    !      SEED      SEED
    !
    !         12345   207482415  0.096616
    !     207482415  1790989824  0.833995
    !    1790989824  2035175616  0.947702
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    31 May 2007
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Paul Bratley, Bennett Fox, Linus Schrage,
    !    A Guide to Simulation,
    !    Second Edition,
    !    Springer, 1987,
    !    ISBN: 0387964673,
    !    LC: QA76.9.C65.B73.
    !
    !    Bennett Fox,
    !    Algorithm 647:
    !    Implementation and Relative Efficiency of Quasirandom
    !    Sequence Generators,
    !    ACM Transactions on Mathematical Software,
    !    Volume 12, Number 4, December 1986, pages 362-376.
    !
    !    Pierre L'Ecuyer,
    !    Random Number Generation,
    !    in Handbook of Simulation,
    !    edited by Jerry Banks,
    !    Wiley, 1998,
    !    ISBN: 0471134031,
    !    LC: T57.62.H37.
    !
    !    Peter Lewis, Allen Goodman, James Miller,
    !    A Pseudo-Random Number Generator for the System/360,
    !    IBM Systems Journal,
    !    Volume 8, Number 2, 1969, pages 136-143.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
    !    should NOT be 0.  On output, SEED has been updated.
    !
    !    Output, real ( kind = 4 ) R4_UNIFORM_01, a new pseudorandom variate,
    !    strictly between 0 and 1.
    !
    implicit none

    integer ( kind = 4 ), parameter :: i4_huge = 2147483647
    integer ( kind = 4 ) k
    integer ( kind = 4 ) seed
    real ( kind = 4 ) r4_uniform_01

    if ( seed == 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R4_UNIFORM_01 - Fatal error!'
        write ( *, '(a)' ) '  Input value of SEED = 0.'
        stop 1
    end if

    k = seed / 127773

    seed = 16807 * ( seed - k * 127773 ) - k * 2836

    if ( seed < 0 ) then
        seed = seed + i4_huge
    end if

    r4_uniform_01 = real ( seed, kind = 4 ) * 4.656612875E-10

    return
    end
    subroutine r4vec_uniform_01 ( n, seed, r )

    !*****************************************************************************80
    !
    !! R4VEC_UNIFORM_01 returns a unit pseudorandom R4VEC.
    !
    !  Discussion:
    !
    !    An R4VEC is an array of real ( kind = 4 ) values.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    31 May 2007
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Paul Bratley, Bennett Fox, Linus Schrage,
    !    A Guide to Simulation,
    !    Second Edition,
    !    Springer, 1987,
    !    ISBN: 0387964673,
    !    LC: QA76.9.C65.B73.
    !
    !    Bennett Fox,
    !    Algorithm 647:
    !    Implementation and Relative Efficiency of Quasirandom
    !    Sequence Generators,
    !    ACM Transactions on Mathematical Software,
    !    Volume 12, Number 4, December 1986, pages 362-376.
    !
    !    Pierre L'Ecuyer,
    !    Random Number Generation,
    !    in Handbook of Simulation,
    !    edited by Jerry Banks,
    !    Wiley, 1998,
    !    ISBN: 0471134031,
    !    LC: T57.62.H37.
    !
    !    Peter Lewis, Allen Goodman, James Miller,
    !    A Pseudo-Random Number Generator for the System/360,
    !    IBM Systems Journal,
    !    Volume 8, Number 2, 1969, pages 136-143.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) N, the number of entries in the vector.
    !
    !    Input/output, integer ( kind = 4 ) SEED, the "seed" value,
    !    which should NOT be 0.
    !    On output, SEED has been updated.
    !
    !    Output, real ( kind = 4 ) R(N), the vector of pseudorandom values.
    !
    implicit none

    integer ( kind = 4 ) n

    integer ( kind = 4 ) i
    integer ( kind = 4 ), parameter :: i4_huge = 2147483647
    integer ( kind = 4 ) k
    integer ( kind = 4 ) seed
    real ( kind = 4 ) r(n)

    if ( seed == 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R4VEC_UNIFORM_01 - Fatal error!'
        write ( *, '(a)' ) '  Input value of SEED = 0.'
        stop 1
    end if

    do i = 1, n

        k = seed / 127773

        seed = 16807 * ( seed - k * 127773 ) - k * 2836

        if ( seed < 0 ) then
            seed = seed + i4_huge
        end if

        r(i) = real ( seed, kind = 4 ) * 4.656612875E-10

    end do

    return
    end
    subroutine r4vec_normal_ab ( n, a, b, seed, x )

    !*****************************************************************************80
    !
    !! R4VEC_NORMAL_AB returns a scaled pseudonormal R4VEC.
    !
    !  Discussion:
    !
    !    The standard normal probability distribution function (PDF) has
    !    mean 0 and standard deviation 1.
    !
    !    An R4VEC is a vector of R4's.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    06 August 2013
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) N, the number of values desired.
    !
    !    Input, real ( kind = 4 ) A, B, the mean and standard deviation.
    !
    !    Input/output, integer ( kind = 4 ) SEED, a seed for the random
    !    number generator.
    !
    !    Output, real ( kind = 4 ) X(N), a sample of the standard normal PDF.
    !
    !  Local parameters:
    !
    !    Local, real ( kind = 4 ) R(N+1), is used to store some uniform
    !    random values.  Its dimension is N+1, but really it is only needed
    !    to be the smallest even number greater than or equal to N.
    !
    !    Local, integer ( kind = 4 ) X_LO_INDEX, X_HI_INDEX, records the range
    !    of entries of X that we need to compute.
    !
    implicit none

    integer ( kind = 4 ) n

    real ( kind = 4 ) a
    real ( kind = 4 ) b
    integer ( kind = 4 ) m
    real ( kind = 4 ) r(n+1)
    real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
    real ( kind = 4 ) r4_uniform_01
    integer ( kind = 4 ) seed
    real ( kind = 4 ) x(n)
    integer ( kind = 4 ) x_hi_index
    integer ( kind = 4 ) x_lo_index
    !
    !  Record the range of X we need to fill in.
    !
    x_lo_index = 1
    x_hi_index = n
    !
    !  If we need just one new value, do that here to avoid null arrays.
    !
    if ( x_hi_index - x_lo_index + 1 == 1 ) then

        r(1) = r4_uniform_01 ( seed )

        if ( r(1) == 0.0E+00 ) then
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'R4VEC_NORMAL_AB - Fatal error!'
            write ( *, '(a)' ) '  R4_UNIFORM_01 returned a value of 0.'
            stop 1
        end if

        r(2) = r4_uniform_01 ( seed )

        x(x_hi_index) = &
            sqrt ( - 2.0E+00 * log ( r(1) ) ) * cos ( 2.0E+00 * r4_pi * r(2) )
        !
        !  If we require an even number of values, that's easy.
        !
    else if ( mod ( x_hi_index - x_lo_index, 2 ) == 1 ) then

        m = ( x_hi_index - x_lo_index + 1 ) / 2

        call r4vec_uniform_01 ( 2*m, seed, r )

        x(x_lo_index:x_hi_index-1:2) = &
            sqrt ( - 2.0E+00 * log ( r(1:2*m-1:2) ) ) &
            * cos ( 2.0E+00 * r4_pi * r(2:2*m:2) )

        x(x_lo_index+1:x_hi_index:2) = &
            sqrt ( - 2.0E+00 * log ( r(1:2*m-1:2) ) ) &
            * sin ( 2.0E+00 * r4_pi * r(2:2*m:2) )
        !
        !  If we require an odd number of values, we generate an even number,
        !  and handle the last pair specially, storing one in X(N), and
        !  saving the other for later.
        !
    else

        x_hi_index = x_hi_index - 1

        m = ( x_hi_index - x_lo_index + 1 ) / 2 + 1

        call r4vec_uniform_01 ( 2*m, seed, r )

        x(x_lo_index:x_hi_index-1:2) = &
            sqrt ( - 2.0E+00 * log ( r(1:2*m-3:2) ) ) &
            * cos ( 2.0E+00 * r4_pi * r(2:2*m-2:2) )

        x(x_lo_index+1:x_hi_index:2) = &
            sqrt ( - 2.0E+00 * log ( r(1:2*m-3:2) ) ) &
            * sin ( 2.0E+00 * r4_pi * r(2:2*m-2:2) )

        x(n) = sqrt ( - 2.0E+00 * log ( r(2*m-1) ) ) &
            * cos ( 2.0E+00 * r4_pi * r(2*m) )

    end if

    x(1:n) = a + b * x(1:n)

    return
    end
    function r8_normal_01 ( seed )

    !*****************************************************************************80
    !
    !! R8_NORMAL_01 returns a unit pseudonormal R8.
    !
    !  Discussion:
    !
    !    The standard normal probability distribution function (PDF) has
    !    mean 0 and standard deviation 1.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    06 August 2013
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) SEED, a seed for the random
    !    number generator.
    !
    !    Output, real ( kind = 8 ) R8_NORMAL_01, a normally distributed
    !    random value.
    !
    implicit none

    real ( kind = 8 ) r1
    real ( kind = 8 ) r2
    real ( kind = 8 ) r8_normal_01
    real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
    real ( kind = 8 ) r8_uniform_01
    integer ( kind = 4 ) seed
    real ( kind = 8 ) x

    r1 = r8_uniform_01 ( seed )
    r2 = r8_uniform_01 ( seed )
    x = sqrt ( - 2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * r8_pi * r2 )

    r8_normal_01 = x

    return
    end
    function r8_normal_ab ( a, b, seed )

    !*****************************************************************************80
    !
    !! R8_NORMAL_AB returns a scaled pseudonormal R8.
    !
    !  Discussion:
    !
    !    The normal probability distribution function (PDF) is sampled,
    !    with mean A and standard deviation B.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    06 August 2013
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, the mean of the PDF.
    !
    !    Input, real ( kind = 8 ) B, the standard deviation of the PDF.
    !
    !    Input/output, integer ( kind = 4 ) SEED, a seed for the random
    !    number generator.
    !
    !    Output, real ( kind = 8 ) R8_NORMAL_AB, a sample of the normal PDF.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) b
    real ( kind = 8 ) r1
    real ( kind = 8 ) r2
    real ( kind = 8 ) r8_normal_ab
    real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
    real ( kind = 8 ) r8_uniform_01
    integer ( kind = 4 ) seed
    real ( kind = 8 ) x

    r1 = r8_uniform_01 ( seed )
    r2 = r8_uniform_01 ( seed )
    x = sqrt ( - 2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * r8_pi * r2 )

    r8_normal_ab = a + b * x

    return
    end
    function r8_uniform_01 ( seed )

    !*****************************************************************************80
    !
    !! R8_UNIFORM_01 returns a unit pseudorandom R8.
    !
    !  Discussion:
    !
    !    This routine implements the recursion
    !
    !      seed = 16807 * seed mod ( 2^31 - 1 )
    !      r8_uniform_01 = seed / ( 2^31 - 1 )
    !
    !    The integer arithmetic never requires more than 32 bits,
    !    including a sign bit.
    !
    !    If the initial seed is 12345, then the first three computations are
    !
    !      Input     Output      R8_UNIFORM_01
    !      SEED      SEED
    !
    !         12345   207482415  0.096616
    !     207482415  1790989824  0.833995
    !    1790989824  2035175616  0.947702
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    31 May 2007
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Paul Bratley, Bennett Fox, Linus Schrage,
    !    A Guide to Simulation,
    !    Second Edition,
    !    Springer, 1987,
    !    ISBN: 0387964673,
    !    LC: QA76.9.C65.B73.
    !
    !    Bennett Fox,
    !    Algorithm 647:
    !    Implementation and Relative Efficiency of Quasirandom
    !    Sequence Generators,
    !    ACM Transactions on Mathematical Software,
    !    Volume 12, Number 4, December 1986, pages 362-376.
    !
    !    Pierre L'Ecuyer,
    !    Random Number Generation,
    !    in Handbook of Simulation,
    !    edited by Jerry Banks,
    !    Wiley, 1998,
    !    ISBN: 0471134031,
    !    LC: T57.62.H37.
    !
    !    Peter Lewis, Allen Goodman, James Miller,
    !    A Pseudo-Random Number Generator for the System/360,
    !    IBM Systems Journal,
    !    Volume 8, 1969, pages 136-143.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
    !    should NOT be 0.
    !    On output, SEED has been updated.
    !
    !    Output, real ( kind = 8 ) R8_UNIFORM_01, a new pseudorandom variate,
    !    strictly between 0 and 1.
    !
    implicit none

    integer ( kind = 4 ) k
    real ( kind = 8 ) r8_uniform_01
    integer ( kind = 4 ) seed

    k = seed / 127773

    seed = 16807 * ( seed - k * 127773 ) - k * 2836

    if ( seed < 0 ) then
        seed = seed + 2147483647
    end if
    !
    !  Although SEED can be represented exactly as a 32 bit integer,
    !  it generally cannot be represented exactly as a 32 bit real number!
    !
    r8_uniform_01 = real ( seed, kind = 8 ) * 4.656612875D-10

    return
    end
    subroutine r8mat_normal_01 ( m, n, seed, r )

    !*****************************************************************************80
    !
    !! R8MAT_NORMAL_01 returns a unit pseudonormal R8MAT.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    12 November 2010
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Paul Bratley, Bennett Fox, Linus Schrage,
    !    A Guide to Simulation,
    !    Second Edition,
    !    Springer, 1987,
    !    ISBN: 0387964673,
    !    LC: QA76.9.C65.B73.
    !
    !    Bennett Fox,
    !    Algorithm 647:
    !    Implementation and Relative Efficiency of Quasirandom
    !    Sequence Generators,
    !    ACM Transactions on Mathematical Software,
    !    Volume 12, Number 4, December 1986, pages 362-376.
    !
    !    Pierre L'Ecuyer,
    !    Random Number Generation,
    !    in Handbook of Simulation,
    !    edited by Jerry Banks,
    !    Wiley, 1998,
    !    ISBN: 0471134031,
    !    LC: T57.62.H37.
    !
    !    Peter Lewis, Allen Goodman, James Miller,
    !    A Pseudo-Random Number Generator for the System/360,
    !    IBM Systems Journal,
    !    Volume 8, 1969, pages 136-143.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) M, N, the number of rows and columns
    !    in the array.
    !
    !    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
    !    should NOT be 0.  On output, SEED has been updated.
    !
    !    Output, real ( kind = 8 ) R(M,N), the array of pseudonormal values.
    !
    implicit none

    integer ( kind = 4 ) m
    integer ( kind = 4 ) n

    integer ( kind = 4 ) seed
    real ( kind = 8 ) r(m,n)

    call r8vec_normal_01 ( m * n, seed, r )

    return
    end
    subroutine r8mat_normal_ab ( m, n, a, b, seed, r )

    !*****************************************************************************80
    !
    !! R8MAT_NORMAL_AB returns a scaled pseudonormal R8MAT.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    06 August 2013
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Paul Bratley, Bennett Fox, Linus Schrage,
    !    A Guide to Simulation,
    !    Second Edition,
    !    Springer, 1987,
    !    ISBN: 0387964673,
    !    LC: QA76.9.C65.B73.
    !
    !    Bennett Fox,
    !    Algorithm 647:
    !    Implementation and Relative Efficiency of Quasirandom
    !    Sequence Generators,
    !    ACM Transactions on Mathematical Software,
    !    Volume 12, Number 4, December 1986, pages 362-376.
    !
    !    Pierre L'Ecuyer,
    !    Random Number Generation,
    !    in Handbook of Simulation,
    !    edited by Jerry Banks,
    !    Wiley, 1998,
    !    ISBN: 0471134031,
    !    LC: T57.62.H37.
    !
    !    Peter Lewis, Allen Goodman, James Miller,
    !    A Pseudo-Random Number Generator for the System/360,
    !    IBM Systems Journal,
    !    Volume 8, 1969, pages 136-143.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) M, N, the number of rows and columns
    !    in the array.
    !
    !    Input, real ( kind = 8 ) A, B, the mean and standard deviation.
    !
    !    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
    !    should NOT be 0.  On output, SEED has been updated.
    !
    !    Output, real ( kind = 8 ) R(M,N), the array of pseudonormal values.
    !
    implicit none

    integer ( kind = 4 ) m
    integer ( kind = 4 ) n

    real ( kind = 8 ) a
    real ( kind = 8 ) b
    integer ( kind = 4 ) seed
    real ( kind = 8 ) r(m,n)

    call r8vec_normal_ab ( m * n, a, b, seed, r )

    return
    end
    subroutine r8mat_print ( m, n, a, title )

    !*****************************************************************************80
    !
    !! R8MAT_PRINT prints an R8MAT.
    !
    !  Discussion:
    !
    !    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    12 September 2004
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) M, the number of rows in A.
    !
    !    Input, integer ( kind = 4 ) N, the number of columns in A.
    !
    !    Input, real ( kind = 8 ) A(M,N), the matrix.
    !
    !    Input, character ( len = * ) TITLE, a title.
    !
    implicit none

    integer ( kind = 4 ) m
    integer ( kind = 4 ) n

    real ( kind = 8 ) a(m,n)
    character ( len = * ) title

    call r8mat_print_some ( m, n, a, 1, 1, m, n, title )

    return
    end
    subroutine r8mat_print_some ( m, n, a, ilo, jlo, ihi, jhi, title )

    !*****************************************************************************80
    !
    !! R8MAT_PRINT_SOME prints some of an R8MAT.
    !
    !  Discussion:
    !
    !    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    10 September 2009
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) M, N, the number of rows and columns.
    !
    !    Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed.
    !
    !    Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print.
    !
    !    Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print.
    !
    !    Input, character ( len = * ) TITLE, a title.
    !
    implicit none

    integer ( kind = 4 ), parameter :: incx = 5
    integer ( kind = 4 ) m
    integer ( kind = 4 ) n

    real ( kind = 8 ) a(m,n)
    character ( len = 14 ) ctemp(incx)
    integer ( kind = 4 ) i
    integer ( kind = 4 ) i2hi
    integer ( kind = 4 ) i2lo
    integer ( kind = 4 ) ihi
    integer ( kind = 4 ) ilo
    integer ( kind = 4 ) inc
    integer ( kind = 4 ) j
    integer ( kind = 4 ) j2
    integer ( kind = 4 ) j2hi
    integer ( kind = 4 ) j2lo
    integer ( kind = 4 ) jhi
    integer ( kind = 4 ) jlo
    character ( len = * ) title

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) trim ( title )

    if ( m <= 0 .or. n <= 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) '  (None)'
        return
    end if

    do j2lo = max ( jlo, 1 ), min ( jhi, n ), incx

        j2hi = j2lo + incx - 1
        j2hi = min ( j2hi, n )
        j2hi = min ( j2hi, jhi )

        inc = j2hi + 1 - j2lo

        write ( *, '(a)' ) ' '

        do j = j2lo, j2hi
            j2 = j + 1 - j2lo
            write ( ctemp(j2), '(i8,6x)' ) j
        end do

        write ( *, '(''  Col   '',5a14)' ) ctemp(1:inc)
        write ( *, '(a)' ) '  Row'
        write ( *, '(a)' ) ' '

        i2lo = max ( ilo, 1 )
        i2hi = min ( ihi, m )

        do i = i2lo, i2hi

            do j2 = 1, inc

                j = j2lo - 1 + j2

                if ( a(i,j) == real ( int ( a(i,j) ), kind = 8 ) ) then
                    write ( ctemp(j2), '(f8.0,6x)' ) a(i,j)
                else
                    write ( ctemp(j2), '(g14.6)' ) a(i,j)
                end if

            end do

            write ( *, '(i5,a,5a14)' ) i, ':', ( ctemp(j), j = 1, inc )

        end do

    end do

    return
    end
    subroutine r8vec_normal_01 ( n, seed, x )

    !*****************************************************************************80
    !
    !! R8VEC_NORMAL_01 returns a unit pseudonormal R8VEC.
    !
    !  Discussion:
    !
    !    An R8VEC is an array of double precision real values.
    !
    !    The standard normal probability distribution function (PDF) has
    !    mean 0 and standard deviation 1.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    18 May 2014
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) N, the number of values desired.
    !
    !    Input/output, integer ( kind = 4 ) SEED, a seed for the random
    !    number generator.
    !
    !    Output, real ( kind = 8 ) X(N), a sample of the standard normal PDF.
    !
    !  Local parameters:
    !
    !    Local, real ( kind = 8 ) R(N+1), is used to store some uniform
    !    random values.  Its dimension is N+1, but really it is only needed
    !    to be the smallest even number greater than or equal to N.
    !
    !    Local, integer ( kind = 4 ) X_LO_INDEX, X_HI_INDEX, records the range
    !    of entries of X that we need to compute
    !
    implicit none

    integer ( kind = 4 ) n

    integer ( kind = 4 ) m
    real ( kind = 8 ) r(n+1)
    real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
    real ( kind = 8 ) r8_uniform_01
    integer ( kind = 4 ) seed
    real ( kind = 8 ) x(n)
    integer ( kind = 4 ) x_hi_index
    integer ( kind = 4 ) x_lo_index
    !
    !  Record the range of X we need to fill in.
    !
    x_lo_index = 1
    x_hi_index = n
    !
    !  If we need just one new value, do that here to avoid null arrays.
    !
    if ( x_hi_index - x_lo_index + 1 == 1 ) then

        r(1) = r8_uniform_01 ( seed )

        if ( r(1) == 0.0D+00 ) then
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'R8VEC_NORMAL_01 - Fatal error!'
            write ( *, '(a)' ) '  R8_UNIFORM_01 returned a value of 0.'
            stop 1
        end if

        r(2) = r8_uniform_01 ( seed )

        x(x_hi_index) = &
            sqrt ( - 2.0D+00 * log ( r(1) ) ) * cos ( 2.0D+00 * r8_pi * r(2) )
        !
        !  If we require an even number of values, that's easy.
        !
    else if ( mod ( x_hi_index - x_lo_index, 2 ) == 1 ) then

        m = ( x_hi_index - x_lo_index + 1 ) / 2

        call r8vec_uniform_01 ( 2*m, seed, r )

        x(x_lo_index:x_hi_index-1:2) = &
            sqrt ( - 2.0D+00 * log ( r(1:2*m-1:2) ) ) &
            * cos ( 2.0D+00 * r8_pi * r(2:2*m:2) )

        x(x_lo_index+1:x_hi_index:2) = &
            sqrt ( - 2.0D+00 * log ( r(1:2*m-1:2) ) ) &
            * sin ( 2.0D+00 * r8_pi * r(2:2*m:2) )
        !
        !  If we require an odd number of values, we generate an even number,
        !  and handle the last pair specially, storing one in X(N), and
        !  saving the other for later.
        !
    else

        x_hi_index = x_hi_index - 1

        m = ( x_hi_index - x_lo_index + 1 ) / 2 + 1

        call r8vec_uniform_01 ( 2*m, seed, r )

        x(x_lo_index:x_hi_index-1:2) = &
            sqrt ( - 2.0D+00 * log ( r(1:2*m-3:2) ) ) &
            * cos ( 2.0D+00 * r8_pi * r(2:2*m-2:2) )

        x(x_lo_index+1:x_hi_index:2) = &
            sqrt ( - 2.0D+00 * log ( r(1:2*m-3:2) ) ) &
            * sin ( 2.0D+00 * r8_pi * r(2:2*m-2:2) )

        x(n) = sqrt ( - 2.0D+00 * log ( r(2*m-1) ) ) &
            * cos ( 2.0D+00 * r8_pi * r(2*m) )

    end if

    return
    end
    subroutine r8vec_normal_ab ( n, a, b, seed, x )

    !*****************************************************************************80
    !
    !! R8VEC_NORMAL_AB returns a scaled pseudonormal R8VEC.
    !
    !  Discussion:
    !
    !    The standard normal probability distribution function (PDF) has
    !    mean 0 and standard deviation 1.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    06 August 2013
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) N, the number of values desired.
    !
    !    Input, real ( kind = 8 ) A, B, the mean and standard deviation.
    !
    !    Input/output, integer ( kind = 4 ) SEED, a seed for the random
    !    number generator.
    !
    !    Output, real ( kind = 8 ) X(N), a sample of the standard normal PDF.
    !
    !  Local parameters:
    !
    !    Local, real ( kind = 8 ) R(N+1), is used to store some uniform
    !    random values.  Its dimension is N+1, but really it is only needed
    !    to be the smallest even number greater than or equal to N.
    !
    !    Local, integer ( kind = 4 ) X_LO_INDEX, X_HI_INDEX, records the range
    !    of entries of X that we need to compute.
    !
    implicit none

    integer ( kind = 4 ) n

    real ( kind = 8 ) a
    real ( kind = 8 ) b
    integer ( kind = 4 ) m
    real ( kind = 8 ) r(n+1)
    real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
    real ( kind = 8 ) r8_uniform_01
    integer ( kind = 4 ) seed
    real ( kind = 8 ) x(n)
    integer ( kind = 4 ) x_hi_index
    integer ( kind = 4 ) x_lo_index
    !
    !  Record the range of X we need to fill in.
    !
    x_lo_index = 1
    x_hi_index = n
    !
    !  If we need just one new value, do that here to avoid null arrays.
    !
    if ( x_hi_index - x_lo_index + 1 == 1 ) then

        r(1) = r8_uniform_01 ( seed )

        if ( r(1) == 0.0D+00 ) then
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'R8VEC_NORMAL_AB - Fatal error!'
            write ( *, '(a)' ) '  R8_UNIFORM_01 returned a value of 0.'
            stop 1
        end if

        r(2) = r8_uniform_01 ( seed )

        x(x_hi_index) = &
            sqrt ( - 2.0D+00 * log ( r(1) ) ) * cos ( 2.0D+00 * r8_pi * r(2) )
        !
        !  If we require an even number of values, that's easy.
        !
    else if ( mod ( x_hi_index - x_lo_index, 2 ) == 1 ) then

        m = ( x_hi_index - x_lo_index + 1 ) / 2

        call r8vec_uniform_01 ( 2*m, seed, r )

        x(x_lo_index:x_hi_index-1:2) = &
            sqrt ( - 2.0D+00 * log ( r(1:2*m-1:2) ) ) &
            * cos ( 2.0D+00 * r8_pi * r(2:2*m:2) )

        x(x_lo_index+1:x_hi_index:2) = &
            sqrt ( - 2.0D+00 * log ( r(1:2*m-1:2) ) ) &
            * sin ( 2.0D+00 * r8_pi * r(2:2*m:2) )
        !
        !  If we require an odd number of values, we generate an even number,
        !  and handle the last pair specially, storing one in X(N), and
        !  saving the other for later.
        !
    else

        x_hi_index = x_hi_index - 1

        m = ( x_hi_index - x_lo_index + 1 ) / 2 + 1

        call r8vec_uniform_01 ( 2*m, seed, r )

        x(x_lo_index:x_hi_index-1:2) = &
            sqrt ( - 2.0D+00 * log ( r(1:2*m-3:2) ) ) &
            * cos ( 2.0D+00 * r8_pi * r(2:2*m-2:2) )

        x(x_lo_index+1:x_hi_index:2) = &
            sqrt ( - 2.0D+00 * log ( r(1:2*m-3:2) ) ) &
            * sin ( 2.0D+00 * r8_pi * r(2:2*m-2:2) )

        x(n) = sqrt ( - 2.0D+00 * log ( r(2*m-1) ) ) &
            * cos ( 2.0D+00 * r8_pi * r(2*m) )

    end if

    x(1:n) = a + b * x(1:n)

    return
    end
    subroutine r8vec_print ( n, a, title )

    !*****************************************************************************80
    !
    !! R8VEC_PRINT prints an R8VEC.
    !
    !  Discussion:
    !
    !    An R8VEC is a vector of R8's.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    22 August 2000
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) N, the number of components of the vector.
    !
    !    Input, real ( kind = 8 ) A(N), the vector to be printed.
    !
    !    Input, character ( len = * ) TITLE, a title.
    !
    implicit none

    integer ( kind = 4 ) n

    real ( kind = 8 ) a(n)
    integer ( kind = 4 ) i
    character ( len = * ) title

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) trim ( title )
    write ( *, '(a)' ) ' '

    do i = 1, n
        write ( *, '(2x,i8,a,1x,g16.8)' ) i, ':', a(i)
    end do

    return
    end
    subroutine r8vec_uniform_01 ( n, seed, r )

    !*****************************************************************************80
    !
    !! R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    31 May 2007
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Paul Bratley, Bennett Fox, Linus Schrage,
    !    A Guide to Simulation,
    !    Second Edition,
    !    Springer, 1987,
    !    ISBN: 0387964673,
    !    LC: QA76.9.C65.B73.
    !
    !    Bennett Fox,
    !    Algorithm 647:
    !    Implementation and Relative Efficiency of Quasirandom
    !    Sequence Generators,
    !    ACM Transactions on Mathematical Software,
    !    Volume 12, Number 4, December 1986, pages 362-376.
    !
    !    Pierre L'Ecuyer,
    !    Random Number Generation,
    !    in Handbook of Simulation,
    !    edited by Jerry Banks,
    !    Wiley, 1998,
    !    ISBN: 0471134031,
    !    LC: T57.62.H37.
    !
    !    Peter Lewis, Allen Goodman, James Miller,
    !    A Pseudo-Random Number Generator for the System/360,
    !    IBM Systems Journal,
    !    Volume 8, 1969, pages 136-143.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) N, the number of entries in the vector.
    !
    !    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
    !    should NOT be 0.  On output, SEED has been updated.
    !
    !    Output, real ( kind = 8 ) R(N), the vector of pseudorandom values.
    !
    implicit none

    integer ( kind = 4 ) n

    integer ( kind = 4 ) i
    integer ( kind = 4 ) k
    integer ( kind = 4 ) seed
    real ( kind = 8 ) r(n)

    do i = 1, n

        k = seed / 127773

        seed = 16807 * ( seed - k * 127773 ) - k * 2836

        if ( seed < 0 ) then
            seed = seed + 2147483647
        end if

        r(i) = real ( seed, kind = 8 ) * 4.656612875D-10

    end do

    return
    end
    subroutine timestamp ( )

    !*****************************************************************************80
    !
    !! TIMESTAMP prints the current YMDHMS date as a time stamp.
    !
    !  Example:
    !
    !    31 May 2001   9:45:54.872 AM
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    18 May 2013
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    None
    !
    implicit none

    character ( len = 8 ) ampm
    integer ( kind = 4 ) d
    integer ( kind = 4 ) h
    integer ( kind = 4 ) m
    integer ( kind = 4 ) mm
    character ( len = 9 ), parameter, dimension(12) :: month = (/ &
        'January  ', 'February ', 'March    ', 'April    ', &
        'May      ', 'June     ', 'July     ', 'August   ', &
        'September', 'October  ', 'November ', 'December ' /)
    integer ( kind = 4 ) n
    integer ( kind = 4 ) s
    integer ( kind = 4 ) values(8)
    integer ( kind = 4 ) y

    call date_and_time ( values = values )

    y = values(1)
    m = values(2)
    d = values(3)
    h = values(5)
    n = values(6)
    s = values(7)
    mm = values(8)

    if ( h < 12 ) then
        ampm = 'AM'
    else if ( h == 12 ) then
        if ( n == 0 .and. s == 0 ) then
            ampm = 'Noon'
        else
            ampm = 'PM'
        end if
    else
        h = h - 12
        if ( h < 12 ) then
            ampm = 'PM'
        else if ( h == 12 ) then
            if ( n == 0 .and. s == 0 ) then
                ampm = 'Midnight'
            else
                ampm = 'AM'
            end if
        end if
    end if

    write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
        d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

    return
    end

    subroutine basef(nvar,xvar,xel,basis,indh)
    implicit none
    integer, intent(in)  :: nvar
    real*8, intent(in)   :: xvar(nvar),xel
    real*8, intent(out)  :: basis(2)
    integer, intent(out) :: indh(2)
    integer              :: tind

    call locate2(nvar,xvar,xel,tind)
    if (tind==0) then
        indh(1) = 1
        indh(2) = 2
        basis(1) = 1.0
        basis(2) = 0.0
    elseif (tind==nvar) then
        indh(1) = nvar-1
        indh(2) = nvar
        basis(1) =  0.0
        basis(2) = 1.0
    else
        indh(1)  = tind
        indh(2)  = tind+1
        basis(1) = (xvar(indh(2))-xel)/(xvar(indh(2))-xvar(indh(1)))
        basis(2) = (xel-xvar(indh(1)))/(xvar(indh(2))-xvar(indh(1)))
    end if
    !print *, 'hh', tind,indh,basis,xvar(indh(2)),xvar(indh(1)),xel
    end subroutine basef

    !**************************************
    subroutine locate2(n,xx,xvar,jlo)
    ! given an array xx(1:n), and given a value x, returns a value j such that x is between xx(j) and xx(j+1).
    ! xx must be monotonic, either increasing or decreasing. j=0 or j=N is returned to indicate that x is out of range.
    implicit none
    integer, intent(in):: n
    real*8, intent(in):: xx(n),xvar
    integer, intent(out):: jlo

    integer:: jl,jm,ju
    logical:: ascnd

    ascnd=(xx(n)>=xx(1))
    jl=0
    ju=n+1
    do
        if (ju-jl<=1) exit
        jm=(ju+jl)/2
        if (ascnd .eqv. (xvar>=xx(jm))) then
            jl=jm
        else
            ju=jm
        end if
    end do
    if (xvar==xx(1)) then
        jlo=1
    else if (xvar==xx(n)) then
        jlo=n-1
    else
        jlo=jl
    end if

    end subroutine locate2






    subroutine unique(n,example,res,k)
    implicit none
    integer, intent(in) :: n
    real(8), intent(in) :: example(n)         ! The input
    real(8), intent(out) :: res(n)  ! The output
    integer, intent(out) :: k ! number of unique elements
    integer :: i, j
    res = 0.0
    k = 1
    res(1) = example(1)
    outer: do i=2,size(example)
        do j=1,k
            if (res(j) == example(i)) then           ! Found a match so start looking again
                cycle outer
            end if
        end do     ! No match found so add it to the output
        k = k + 1
        res(k) = example(i)
    end do outer
    end subroutine unique









    subroutine findinv(matrix, inverse, n, errorflag)
    implicit none
    !declarations
    integer, intent(in) :: n
    integer, intent(out) :: errorflag  !return error status. -1 for error, 0 for normal
    double precision, intent(in), dimension(n,n) :: matrix  !input matrix
    double precision, intent(out), dimension(n,n) :: inverse !inverted matrix

    logical :: flag = .true.
    integer :: i, j, k, l
    double precision :: m
    double precision, dimension(n,2*n) :: augmatrix !augmented matrix

    !augment input matrix with an identity matrix
    do i = 1, n
        do j = 1, 2*n
            if (j <= n ) then
                augmatrix(i,j) = matrix(i,j)
            else if ((i+n) == j) then
                augmatrix(i,j) = 1
            else
                augmatrix(i,j) = 0
            endif
        end do
    end do

    !reduce augmented matrix to upper traingular form
    do k =1, n-1
        if (augmatrix(k,k) == 0) then
            flag = .false.
            do i = k+1, n
                if (augmatrix(i,k) /= 0) then
                    do j = 1,2*n
                        augmatrix(k,j) = augmatrix(k,j)+augmatrix(i,j)
                    end do
                    flag = .true.
                    exit
                endif
                if (flag .eqv. .false.) then
                    !  print*, "matrix is non - invertible"
                    inverse = 0
                    errorflag = -1
                    return
                endif
            end do
        endif
        do j = k+1, n
            m = augmatrix(j,k)/augmatrix(k,k)
            do i = k, 2*n
                augmatrix(j,i) = augmatrix(j,i) - m*augmatrix(k,i)
            end do
        end do
    end do

    !test for invertibility
    do i = 1, n
        if (augmatrix(i,i) == 0) then
            !   print*, "matrix is non - invertible"
            inverse = 0
            errorflag = -1
            return
        endif
    end do

    !make diagonal elements as 1
    do i = 1 , n
        m = augmatrix(i,i)
        do j = i , (2 * n)
            augmatrix(i,j) = (augmatrix(i,j) / m)
        end do
    end do

    !reduced right side half of augmented matrix to identity matrix
    do k = n-1, 1, -1
        do i =1, k
            m = augmatrix(i,k+1)
            do j = k, (2*n)
                augmatrix(i,j) = augmatrix(i,j) -augmatrix(k+1,j) * m
            end do
        end do
    end do

    !store answer
    do i =1, n
        do j = 1, n
            inverse(i,j) = augmatrix(i,j+n)
        end do
    end do
    errorflag = 0
    end subroutine findinv

















    function algdiv ( a, b )

    !*****************************************************************************80
    !
    !! ALGDIV computes ln ( Gamma ( B ) / Gamma ( A + B ) ) when 8 <= B.
    !
    !  Discussion:
    !
    !    In this algorithm, DEL(X) is the function defined by
    !
    !      ln ( Gamma(X) ) = ( X - 0.5 ) * ln ( X ) - X + 0.5 * ln ( 2 * PI )
    !                      + DEL(X).
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, B, define the arguments.
    !
    !    Output, real ( kind = 8 ) ALGDIV, the value of ln(Gamma(B)/Gamma(A+B)).
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) algdiv
    real ( kind = 8 ) alnrel
    real ( kind = 8 ) b
    real ( kind = 8 ) c
    real ( kind = 8 ), parameter :: c0 =  0.833333333333333D-01
    real ( kind = 8 ), parameter :: c1 = -0.277777777760991D-02
    real ( kind = 8 ), parameter :: c2 =  0.793650666825390D-03
    real ( kind = 8 ), parameter :: c3 = -0.595202931351870D-03
    real ( kind = 8 ), parameter :: c4 =  0.837308034031215D-03
    real ( kind = 8 ), parameter :: c5 = -0.165322962780713D-02
    real ( kind = 8 ) d
    real ( kind = 8 ) h
    real ( kind = 8 ) s11
    real ( kind = 8 ) s3
    real ( kind = 8 ) s5
    real ( kind = 8 ) s7
    real ( kind = 8 ) s9
    real ( kind = 8 ) t
    real ( kind = 8 ) u
    real ( kind = 8 ) v
    real ( kind = 8 ) w
    real ( kind = 8 ) x
    real ( kind = 8 ) x2

    if ( b < a ) then
        h = b / a
        c = 1.0D+00 / ( 1.0D+00 + h )
        x = h / ( 1.0D+00 + h )
        d = a + ( b - 0.5D+00 )
    else
        h = a / b
        c = h / ( 1.0D+00 + h )
        x = 1.0D+00 / ( 1.0D+00 + h )
        d = b + ( a - 0.5D+00 )
    end if
    !
    !  Set SN = (1 - X^N)/(1 - X).
    !
    x2 = x * x
    s3 = 1.0D+00 + ( x + x2 )
    s5 = 1.0D+00 + ( x + x2 * s3 )
    s7 = 1.0D+00 + ( x + x2 * s5 )
    s9 = 1.0D+00 + ( x + x2 * s7 )
    s11 = 1.0D+00 + ( x + x2 * s9 )
    !
    !  Set W = DEL(B) - DEL(A + B).
    !
    t = ( 1.0D+00 / b )**2
    w = (((( &
        c5 * s11  * t &
        + c4 * s9 ) * t &
        + c3 * s7 ) * t &
        + c2 * s5 ) * t &
        + c1 * s3 ) * t &
        + c0

    w = w * ( c / b )
    !
    !  Combine the results.
    !
    u = d * alnrel ( a / b )
    v = a * ( log ( b ) - 1.0D+00 )

    if ( v < u ) then
        algdiv = ( w - v ) - u
    else
        algdiv = ( w - u ) - v
    end if

    return
    end
    function alnrel ( a )

    !*****************************************************************************80
    !
    !! ALNREL evaluates the function ln ( 1 + A ).
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, the argument.
    !
    !    Output, real ( kind = 8 ) ALNREL, the value of ln ( 1 + A ).
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) alnrel
    real ( kind = 8 ), parameter :: p1 = -0.129418923021993D+01
    real ( kind = 8 ), parameter :: p2 =  0.405303492862024D+00
    real ( kind = 8 ), parameter :: p3 = -0.178874546012214D-01
    real ( kind = 8 ), parameter :: q1 = -0.162752256355323D+01
    real ( kind = 8 ), parameter :: q2 =  0.747811014037616D+00
    real ( kind = 8 ), parameter :: q3 = -0.845104217945565D-01
    real ( kind = 8 ) t
    real ( kind = 8 ) t2
    real ( kind = 8 ) w
    real ( kind = 8 ) x

    if ( abs ( a ) <= 0.375D+00 ) then

        t = a / ( a +  2.0D+00  )
        t2 = t * t

        w = ((( p3 * t2 + p2 ) * t2 + p1 ) * t2 + 1.0D+00 ) &
            / ((( q3 * t2 + q2 ) * t2 + q1 ) * t2 + 1.0D+00 )

        alnrel =  2.0D+00  * t * w

    else

        x = 1.0D+00 + real ( a, kind = 8 )
        alnrel = log ( x )

    end if

    return
    end
    function apser ( a, b, x, eps )

    !*****************************************************************************80
    !
    !! APSER computes the incomplete beta ratio I(SUB(1-X))(B,A).
    !
    !  Discussion:
    !
    !    APSER is used only for cases where
    !
    !      A <= min ( EPS, EPS * B ),
    !      B * X <= 1, and
    !      X <= 0.5.
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, B, X, the parameters of the
    !    incomplete beta ratio.
    !
    !    Input, real ( kind = 8 ) EPS, a tolerance.
    !
    !    Output, real ( kind = 8 ) APSER, the computed value of the
    !    incomplete beta ratio.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) aj
    real ( kind = 8 ) apser
    real ( kind = 8 ) b
    real ( kind = 8 ) bx
    real ( kind = 8 ) c
    real ( kind = 8 ) eps
    real ( kind = 8 ), parameter :: g = 0.577215664901533D+00
    real ( kind = 8 ) j
    real ( kind = 8 ) psi
    real ( kind = 8 ) s
    real ( kind = 8 ) t
    real ( kind = 8 ) tol
    real ( kind = 8 ) x

    bx = b * x
    t = x - bx

    if ( b * eps <= 0.02D+00 ) then
        c = log ( x ) + psi ( b ) + g + t
    else
        c = log ( bx ) + g + t
    end if

    tol = 5.0D+00 * eps * abs ( c )
    j = 1.0D+00
    s = 0.0D+00

    do

        j = j + 1.0D+00
        t = t * ( x - bx / j )
        aj = t / j
        s = s + aj

        if ( abs ( aj ) <= tol ) then
            exit
        end if

    end do

    apser = -a * ( c + s )

    return
    end
    function bcorr ( a0, b0 )

    !*****************************************************************************80
    !
    !! BCORR evaluates DEL(A0) + DEL(B0) - DEL(A0 + B0).
    !
    !  Discussion:
    !
    !    The function DEL(A) is a remainder term that is used in the expression:
    !
    !      ln ( Gamma ( A ) ) = ( A - 0.5 ) * ln ( A )
    !        - A + 0.5 * ln ( 2 * PI ) + DEL ( A ),
    !
    !    or, in other words, DEL ( A ) is defined as:
    !
    !      DEL ( A ) = ln ( Gamma ( A ) ) - ( A - 0.5 ) * ln ( A )
    !        + A + 0.5 * ln ( 2 * PI ).
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A0, B0, the arguments.
    !    It is assumed that 8 <= A0 and 8 <= B0.
    !
    !    Output, real ( kind = 8 ) BCORR, the value of the function.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) a0
    real ( kind = 8 ) b
    real ( kind = 8 ) b0
    real ( kind = 8 ) bcorr
    real ( kind = 8 ) c
    real ( kind = 8 ), parameter :: c0 =  0.833333333333333D-01
    real ( kind = 8 ), parameter :: c1 = -0.277777777760991D-02
    real ( kind = 8 ), parameter :: c2 =  0.793650666825390D-03
    real ( kind = 8 ), parameter :: c3 = -0.595202931351870D-03
    real ( kind = 8 ), parameter :: c4 =  0.837308034031215D-03
    real ( kind = 8 ), parameter :: c5 = -0.165322962780713D-02
    real ( kind = 8 ) h
    real ( kind = 8 ) s11
    real ( kind = 8 ) s3
    real ( kind = 8 ) s5
    real ( kind = 8 ) s7
    real ( kind = 8 ) s9
    real ( kind = 8 ) t
    real ( kind = 8 ) w
    real ( kind = 8 ) x
    real ( kind = 8 ) x2

    a = min ( a0, b0 )
    b = max ( a0, b0 )

    h = a / b
    c = h / ( 1.0D+00 + h )
    x = 1.0D+00 / ( 1.0D+00 + h )
    x2 = x * x
    !
    !  Set SN = (1 - X**N)/(1 - X)
    !
    s3 = 1.0D+00 + ( x + x2 )
    s5 = 1.0D+00 + ( x + x2 * s3 )
    s7 = 1.0D+00 + ( x + x2 * s5 )
    s9 = 1.0D+00 + ( x + x2 * s7 )
    s11 = 1.0D+00 + ( x + x2 * s9 )
    !
    !  Set W = DEL(B) - DEL(A + B)
    !
    t = ( 1.0D+00 / b )**2

    w = (((( &
        c5 * s11  * t &
        + c4 * s9 ) * t &
        + c3 * s7 ) * t &
        + c2 * s5 ) * t &
        + c1 * s3 ) * t &
        + c0

    w = w * ( c / b )
    !
    !  Compute  DEL(A) + W.
    !
    t = ( 1.0D+00 / a )**2

    bcorr = ((((( &
        c5   * t &
        + c4 ) * t &
        + c3 ) * t &
        + c2 ) * t &
        + c1 ) * t &
        + c0 ) / a + w

    return
    end
    function beta ( a, b )

    !*****************************************************************************80
    !
    !! BETA evaluates the beta function.
    !
    !  Modified:
    !
    !    03 December 1999
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, B, the arguments of the beta function.
    !
    !    Output, real ( kind = 8 ) BETA, the value of the beta function.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) b
    real ( kind = 8 ) beta
    real ( kind = 8 ) beta_log

    beta = exp ( beta_log ( a, b ) )

    return
    end
    function beta_asym ( a, b, lambda, eps )

    !*****************************************************************************80
    !
    !! BETA_ASYM computes an asymptotic expansion for IX(A,B), for large A and B.
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, B, the parameters of the function.
    !    A and B should be nonnegative.  It is assumed that both A and B
    !    are greater than or equal to 15.
    !
    !    Input, real ( kind = 8 ) LAMBDA, the value of ( A + B ) * Y - B.
    !    It is assumed that 0 <= LAMBDA.
    !
    !    Input, real ( kind = 8 ) EPS, the tolerance.
    !
    implicit none

    integer ( kind = 4 ), parameter :: num = 20

    real ( kind = 8 ) a
    real ( kind = 8 ) a0(num+1)
    real ( kind = 8 ) b
    real ( kind = 8 ) b0(num+1)
    real ( kind = 8 ) bcorr
    real ( kind = 8 ) beta_asym
    real ( kind = 8 ) bsum
    real ( kind = 8 ) c(num+1)
    real ( kind = 8 ) d(num+1)
    real ( kind = 8 ) dsum
    real ( kind = 8 ), parameter :: e0 = 1.12837916709551D+00
    real ( kind = 8 ), parameter :: e1 = 0.353553390593274D+00
    real ( kind = 8 ) eps
    real ( kind = 8 ) error_fc
    real ( kind = 8 ) f
    real ( kind = 8 ) h
    real ( kind = 8 ) h2
    real ( kind = 8 ) hn
    integer ( kind = 4 ) i
    integer ( kind = 4 ) j
    real ( kind = 8 ) j0
    real ( kind = 8 ) j1
    real ( kind = 8 ) lambda
    integer ( kind = 4 ) m
    integer ( kind = 4 ) mm1
    integer ( kind = 4 ) mmj
    integer ( kind = 4 ) n
    integer ( kind = 4 ) np1
    real ( kind = 8 ) r
    real ( kind = 8 ) r0
    real ( kind = 8 ) r1
    real ( kind = 8 ) rlog1
    real ( kind = 8 ) s
    real ( kind = 8 ) sum1
    real ( kind = 8 ) t
    real ( kind = 8 ) t0
    real ( kind = 8 ) t1
    real ( kind = 8 ) u
    real ( kind = 8 ) w
    real ( kind = 8 ) w0
    real ( kind = 8 ) z
    real ( kind = 8 ) z0
    real ( kind = 8 ) z2
    real ( kind = 8 ) zn
    real ( kind = 8 ) znm1

    beta_asym = 0.0D+00

    if ( a < b ) then
        h = a / b
        r0 = 1.0D+00 / ( 1.0D+00 + h )
        r1 = ( b - a ) / b
        w0 = 1.0D+00 / sqrt ( a * ( 1.0D+00 + h ))
    else
        h = b / a
        r0 = 1.0D+00 / ( 1.0D+00 + h )
        r1 = ( b - a ) / a
        w0 = 1.0D+00 / sqrt ( b * ( 1.0D+00 + h ))
    end if

    f = a * rlog1 ( - lambda / a ) + b * rlog1 ( lambda / b )
    t = exp ( - f )
    if ( t == 0.0D+00 ) then
        return
    end if

    z0 = sqrt ( f )
    z = 0.5D+00 * ( z0 / e1 )
    z2 = f + f

    a0(1) = ( 2.0D+00 / 3.0D+00 ) * r1
    c(1) = -0.5D+00 * a0(1)
    d(1) = -c(1)
    j0 = ( 0.5D+00 / e0 ) * error_fc ( 1, z0 )
    j1 = e1
    sum1 = j0 + d(1) * w0 * j1

    s = 1.0D+00
    h2 = h * h
    hn = 1.0D+00
    w = w0
    znm1 = z
    zn = z2

    do n = 2, num, 2

        hn = h2 * hn
        a0(n) = 2.0D+00 * r0 * ( 1.0D+00 + h * hn ) &
            / ( n + 2.0D+00 )
        np1 = n + 1
        s = s + hn
        a0(np1) = 2.0D+00 * r1 * s / ( n + 3.0D+00 )

        do i = n, np1

            r = -0.5D+00 * ( i + 1.0D+00 )
            b0(1) = r * a0(1)
            do m = 2, i
                bsum = 0.0D+00
                mm1 = m - 1
                do j = 1, mm1
                    mmj = m - j
                    bsum = bsum + ( j * r - mmj ) * a0(j) * b0(mmj)
                end do
                b0(m) = r * a0(m) + bsum / m
            end do

            c(i) = b0(i) / ( i + 1.0D+00 )

            dsum = 0.0
            do j = 1, i-1
                dsum = dsum + d(i-j) * c(j)
            end do
            d(i) = - ( dsum + c(i) )

        end do

        j0 = e1 * znm1 + ( n - 1.0D+00 ) * j0
        j1 = e1 * zn + n * j1
        znm1 = z2 * znm1
        zn = z2 * zn
        w = w0 * w
        t0 = d(n) * w * j0
        w = w0 * w
        t1 = d(np1) * w * j1
        sum1 = sum1 + ( t0 + t1 )

        if ( ( abs ( t0 ) + abs ( t1 )) <= eps * sum1 ) then
            u = exp ( - bcorr ( a, b ) )
            beta_asym = e0 * t * u * sum1
            return
        end if

    end do

    u = exp ( - bcorr ( a, b ) )
    beta_asym = e0 * t * u * sum1

    return
    end
    function beta_frac ( a, b, x, y, lambda, eps )

    !*****************************************************************************80
    !
    !! BETA_FRAC evaluates a continued fraction expansion for IX(A,B).
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, B, the parameters of the function.
    !    A and B should be nonnegative.  It is assumed that both A and
    !    B are greater than 1.
    !
    !    Input, real ( kind = 8 ) X, Y.  X is the argument of the
    !    function, and should satisy 0 <= X <= 1.  Y should equal 1 - X.
    !
    !    Input, real ( kind = 8 ) LAMBDA, the value of ( A + B ) * Y - B.
    !
    !    Input, real ( kind = 8 ) EPS, a tolerance.
    !
    !    Output, real ( kind = 8 ) BETA_FRAC, the value of the continued
    !    fraction approximation for IX(A,B).
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) alpha
    real ( kind = 8 ) an
    real ( kind = 8 ) anp1
    real ( kind = 8 ) b
    real ( kind = 8 ) beta
    real ( kind = 8 ) beta_frac
    real ( kind = 8 ) beta_rcomp
    real ( kind = 8 ) bn
    real ( kind = 8 ) bnp1
    real ( kind = 8 ) c
    real ( kind = 8 ) c0
    real ( kind = 8 ) c1
    real ( kind = 8 ) e
    real ( kind = 8 ) eps
    real ( kind = 8 ) lambda
    real ( kind = 8 ) n
    real ( kind = 8 ) p
    real ( kind = 8 ) r
    real ( kind = 8 ) r0
    real ( kind = 8 ) s
    real ( kind = 8 ) t
    real ( kind = 8 ) w
    real ( kind = 8 ) x
    real ( kind = 8 ) y
    real ( kind = 8 ) yp1

    beta_frac = beta_rcomp ( a, b, x, y )

    if ( beta_frac == 0.0D+00 ) then
        return
    end if

    c = 1.0D+00 + lambda
    c0 = b / a
    c1 = 1.0D+00 + 1.0D+00 / a
    yp1 = y + 1.0D+00

    n = 0.0D+00
    p = 1.0D+00
    s = a + 1.0D+00
    an = 0.0D+00
    bn = 1.0D+00
    anp1 = 1.0D+00
    bnp1 = c / c1
    r = c1 / c
    !
    !  Continued fraction calculation.
    !
    do

        n = n + 1.0D+00
        t = n / a
        w = n * ( b - n ) * x
        e = a / s
        alpha = ( p * ( p + c0 ) * e * e ) * ( w * x )
        e = ( 1.0D+00 + t ) / ( c1 + t + t )
        beta = n + w / s + e * ( c + n * yp1 )
        p = 1.0D+00 + t
        s = s +  2.0D+00
        !
        !  Update AN, BN, ANP1, and BNP1.
        !
        t = alpha * an + beta * anp1
        an = anp1
        anp1 = t
        t = alpha * bn + beta * bnp1
        bn = bnp1
        bnp1 = t

        r0 = r
        r = anp1 / bnp1

        if ( abs ( r - r0 ) <= eps * r ) then
            beta_frac = beta_frac * r
            exit
        end if
        !
        !  Rescale AN, BN, ANP1, and BNP1.
        !
        an = an / bnp1
        bn = bn / bnp1
        anp1 = r
        bnp1 = 1.0D+00

    end do

    return
    end
    subroutine beta_grat ( a, b, x, y, w, eps, ierr )

    !*****************************************************************************80
    !
    !! BETA_GRAT evaluates an asymptotic expansion for IX(A,B).
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, B, the parameters of the function.
    !    A and B should be nonnegative.  It is assumed that 15 <= A
    !    and B <= 1, and that B is less than A.
    !
    !    Input, real ( kind = 8 ) X, Y.  X is the argument of the
    !    function, and should satisy 0 <= X <= 1.  Y should equal 1 - X.
    !
    !    Input/output, real ( kind = 8 ) W, a quantity to which the
    !    result of the computation is to be added on output.
    !
    !    Input, real ( kind = 8 ) EPS, a tolerance.
    !
    !    Output, integer ( kind = 4 ) IERR, an error flag, which is 0 if no error
    !    was detected.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) algdiv
    real ( kind = 8 ) alnrel
    real ( kind = 8 ) b
    real ( kind = 8 ) bm1
    real ( kind = 8 ) bp2n
    real ( kind = 8 ) c(30)
    real ( kind = 8 ) cn
    real ( kind = 8 ) coef
    real ( kind = 8 ) d(30)
    real ( kind = 8 ) dj
    real ( kind = 8 ) eps
    real ( kind = 8 ) gam1
    integer ( kind = 4 ) i
    integer ( kind = 4 ) ierr
    real ( kind = 8 ) j
    real ( kind = 8 ) l
    real ( kind = 8 ) lnx
    integer ( kind = 4 ) n
    real ( kind = 8 ) n2
    real ( kind = 8 ) nu
    real ( kind = 8 ) p
    real ( kind = 8 ) q
    real ( kind = 8 ) r
    real ( kind = 8 ) s
    real ( kind = 8 ) sum1
    real ( kind = 8 ) t
    real ( kind = 8 ) t2
    real ( kind = 8 ) u
    real ( kind = 8 ) v
    real ( kind = 8 ) w
    real ( kind = 8 ) x
    real ( kind = 8 ) y
    real ( kind = 8 ) z

    bm1 = ( b - 0.5D+00 ) - 0.5D+00
    nu = a + 0.5D+00 * bm1

    if ( y <= 0.375D+00 ) then
        lnx = alnrel ( - y )
    else
        lnx = log ( x )
    end if

    z = -nu * lnx

    if ( b * z == 0.0D+00 ) then
        ierr = 1
        return
    end if
    !
    !  Computation of the expansion.
    !
    !  Set R = EXP(-Z)*Z^B/GAMMA(B)
    !
    r = b * ( 1.0D+00 + gam1 ( b ) ) * exp ( b * log ( z ))
    r = r * exp ( a * lnx ) * exp ( 0.5D+00 * bm1 * lnx )
    u = algdiv ( b, a ) + b * log ( nu )
    u = r * exp ( - u )

    if ( u == 0.0D+00 ) then
        ierr = 1
        return
    end if

    call gamma_rat1 ( b, z, r, p, q, eps )

    v = 0.25D+00 * ( 1.0D+00 / nu )**2
    t2 = 0.25D+00 * lnx * lnx
    l = w / u
    j = q / r
    sum1 = j
    t = 1.0D+00
    cn = 1.0D+00
    n2 = 0.0D+00

    do n = 1, 30

        bp2n = b + n2
        j = ( bp2n * ( bp2n + 1.0D+00 ) * j &
            + ( z + bp2n + 1.0D+00 ) * t ) * v
        n2 = n2 +  2.0D+00
        t = t * t2
        cn = cn / ( n2 * ( n2 + 1.0D+00 ))
        c(n) = cn
        s = 0.0D+00

        coef = b - n
        do i = 1, n-1
            s = s + coef * c(i) * d(n-i)
            coef = coef + b
        end do

        d(n) = bm1 * cn + s / n
        dj = d(n) * j
        sum1 = sum1 + dj

        if ( sum1 <= 0.0D+00 ) then
            ierr = 1
            return
        end if

        if ( abs ( dj ) <= eps * ( sum1 + l ) ) then
            ierr = 0
            w = w + u * sum1
            return
        end if

    end do

    ierr = 0
    w = w + u * sum1

    return
    end
    subroutine beta_inc ( a, b, x, y, w, w1, ierr )

    !*****************************************************************************80
    !
    !! BETA_INC evaluates the incomplete beta function IX(A,B).
    !
    !  Author:
    !
    !    Alfred Morris,
    !    Naval Surface Weapons Center,
    !    Dahlgren, Virginia.
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, B, the parameters of the function.
    !    A and B should be nonnegative.
    !
    !    Input, real ( kind = 8 ) X, Y.  X is the argument of the
    !    function, and should satisy 0 <= X <= 1.  Y should equal 1 - X.
    !
    !    Output, real ( kind = 8 ) W, W1, the values of IX(A,B) and
    !    1-IX(A,B).
    !
    !    Output, integer ( kind = 4 ) IERR, the error flag.
    !    0, no error was detected.
    !    1, A or B is negative;
    !    2, A = B = 0;
    !    3, X < 0 or 1 < X;
    !    4, Y < 0 or 1 < Y;
    !    5, X + Y /= 1;
    !    6, X = A = 0;
    !    7, Y = B = 0.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) a0
    real ( kind = 8 ) apser
    real ( kind = 8 ) b
    real ( kind = 8 ) b0
    real ( kind = 8 ) beta_asym
    real ( kind = 8 ) beta_frac
    real ( kind = 8 ) beta_pser
    real ( kind = 8 ) beta_up
    real ( kind = 8 ) eps
    real ( kind = 8 ) fpser
    integer ( kind = 4 ) ierr
    integer ( kind = 4 ) ierr1
    integer ( kind = 4 ) ind
    real ( kind = 8 ) lambda
    integer ( kind = 4 ) n
    real ( kind = 8 ) t
    real ( kind = 8 ) w
    real ( kind = 8 ) w1
    real ( kind = 8 ) x
    real ( kind = 8 ) x0
    real ( kind = 8 ) y
    real ( kind = 8 ) y0
    real ( kind = 8 ) z

    eps = epsilon ( eps )
    w = 0.0D+00
    w1 = 0.0D+00

    if ( a < 0.0D+00 .or. b < 0.0D+00 ) then
        ierr = 1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'BETA_INC - Fatal error!'
        write ( *, '(a,i8)' ) '  IERR = ', ierr
        return
    end if

    if ( a == 0.0D+00 .and. b == 0.0D+00 ) then
        ierr = 2
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'BETA_INC - Fatal error!'
        write ( *, '(a,i8)' ) '  IERR = ', ierr
        return
    end if

    if ( x < 0.0D+00 .or. 1.0D+00 < x ) then
        ierr = 3
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'BETA_INC - Fatal error!'
        write ( *, '(a,i8)' ) '  IERR = ', ierr
        return
    end if

    if ( y < 0.0D+00 .or. 1.0D+00 < y ) then
        ierr = 4
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'BETA_INC - Fatal error!'
        write ( *, '(a,i8)' ) '  IERR = ', ierr
        return
    end if

    z = ( ( x + y ) - 0.5D+00 ) - 0.5D+00

    if ( 3.0D+00 * eps < abs ( z ) ) then
        ierr = 5
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'BETA_INC - Fatal error!'
        write ( *, '(a,i8)' ) '  IERR = ', ierr
        return
    end if

    ierr = 0

    if ( x == 0.0D+00 ) then
        w = 0.0D+00
        w1 = 1.0D+00
        if ( a == 0.0D+00 ) then
            ierr = 6
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'BETA_INC - Fatal error!'
            write ( *, '(a,i8)' ) '  IERR = ', ierr
        end if
        return
    end if

    if ( y == 0.0D+00 ) then
        if ( b == 0.0D+00 ) then
            ierr = 7
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'BETA_INC - Fatal error!'
            write ( *, '(a,i8)' ) '  IERR = ', ierr
            return
        end if
        w = 1.0D+00
        w1 = 0.0D+00
        return
    end if

    if ( a == 0.0D+00 ) then
        w = 1.0D+00
        w1 = 0.0D+00
        return
    end if

    if ( b == 0.0D+00 ) then
        w = 0.0D+00
        w1 = 1.0D+00
        return
    end if

    eps = max ( eps, 1.0D-15 )

    if ( max ( a, b ) < 0.001D+00 * eps ) then
        go to 260
    end if

    ind = 0
    a0 = a
    b0 = b
    x0 = x
    y0 = y

    if ( 1.0D+00 < min ( a0, b0 ) ) then
        go to 40
    end if
    !
    !  Procedure for A0 <= 1 or B0 <= 1
    !
    if ( 0.5D+00 < x ) then
        ind = 1
        a0 = b
        b0 = a
        x0 = y
        y0 = x
    end if

    if ( b0 < min ( eps, eps * a0 ) ) then
        go to 90
    end if

    if ( a0 < min ( eps, eps * b0 ) .and. b0 * x0 <= 1.0D+00 ) then
        go to 100
    end if

    if ( 1.0D+00 < max ( a0, b0 ) ) then
        go to 20
    end if

    if ( min ( 0.2D+00, b0 ) <= a0 ) then
        go to 110
    end if

    if ( x0**a0 <= 0.9D+00 ) then
        go to 110
    end if

    if ( 0.3D+00 <= x0 ) then
        go to 120
    end if

    n = 20
    go to 140

20  continue

    if ( b0 <= 1.0D+00 ) then
        go to 110
    end if

    if ( 0.3D+00 <= x0 ) then
        go to 120
    end if

    if ( 0.1D+00 <= x0 ) then
        go to 30
    end if

    if ( ( x0 * b0 )**a0 <= 0.7D+00 ) then
        go to 110
    end if

30  continue

    if ( 15.0D+00 < b0 ) then
        go to 150
    end if

    n = 20
    go to 140
    !
    !  PROCEDURE for 1 < A0 and 1 < B0.
    !
40  continue

    if ( a <= b ) then
        lambda = a - ( a + b ) * x
    else
        lambda = ( a + b ) * y - b
    end if

    if ( lambda < 0.0D+00 ) then
        ind = 1
        a0 = b
        b0 = a
        x0 = y
        y0 = x
        lambda = abs ( lambda )
    end if

70  continue

    if ( b0 < 40.0D+00 .and. b0 * x0 <= 0.7D+00 ) then
        go to 110
    end if

    if ( b0 < 40.0D+00 ) then
        go to 160
    end if

    if ( b0 < a0 ) then
        go to 80
    end if

    if ( a0 <= 100.0D+00 ) then
        go to 130
    end if

    if ( 0.03D+00 * a0 < lambda ) then
        go to 130
    end if

    go to 200

80  continue

    if ( b0 <= 100.0D+00 ) then
        go to 130
    end if

    if ( 0.03D+00 * b0 < lambda ) then
        go to 130
    end if

    go to 200
    !
    !  Evaluation of the appropriate algorithm.
    !
90  continue

    w = fpser ( a0, b0, x0, eps )
    w1 = 0.5D+00 + ( 0.5D+00 - w )
    go to 250

100 continue

    w1 = apser ( a0, b0, x0, eps )
    w = 0.5D+00 + ( 0.5D+00 - w1 )
    go to 250

110 continue

    w = beta_pser ( a0, b0, x0, eps )
    w1 = 0.5D+00 + ( 0.5D+00 - w )
    go to 250

120 continue

    w1 = beta_pser ( b0, a0, y0, eps )
    w = 0.5D+00 + ( 0.5D+00 - w1 )
    go to 250

130 continue

    w = beta_frac ( a0, b0, x0, y0, lambda, 15.0D+00 * eps )
    w1 = 0.5D+00 + ( 0.5D+00 - w )
    go to 250

140 continue

    w1 = beta_up ( b0, a0, y0, x0, n, eps )
    b0 = b0 + n

150 continue

    call beta_grat ( b0, a0, y0, x0, w1, 15.0D+00 * eps, ierr1 )
    w = 0.5D+00 + ( 0.5D+00 - w1 )
    go to 250

160 continue

    n = b0
    b0 = b0 - n

    if ( b0 == 0.0D+00 ) then
        n = n - 1
        b0 = 1.0D+00
    end if

170 continue

    w = beta_up ( b0, a0, y0, x0, n, eps )

    if ( x0 <= 0.7D+00 ) then
        w = w + beta_pser ( a0, b0, x0, eps )
        w1 = 0.5D+00 + ( 0.5D+00 - w )
        go to 250
    end if

    if ( a0 <= 15.0D+00 ) then
        n = 20
        w = w + beta_up ( a0, b0, x0, y0, n, eps )
        a0 = a0 + n
    end if

190 continue

    call beta_grat ( a0, b0, x0, y0, w, 15.0D+00 * eps, ierr1 )
    w1 = 0.5D+00 + ( 0.5D+00 - w )
    go to 250

200 continue

    w = beta_asym ( a0, b0, lambda, 100.0D+00 * eps )
    w1 = 0.5D+00 + ( 0.5D+00 - w )
    go to 250
    !
    !  Termination of the procedure.
    !
250 continue

    if ( ind /= 0 ) then
        t = w
        w = w1
        w1 = t
    end if

    return
    !
    !  Procedure for A and B < 0.001 * EPS
    !
260 continue

    w = b / ( a + b )
    w1 = a / ( a + b )

    return
    end
    subroutine beta_inc_values ( n_data, a, b, x, fx )

    !*****************************************************************************80
    !
    !! BETA_INC_VALUES returns some values of the incomplete Beta function.
    !
    !  Discussion:
    !
    !    The incomplete Beta function may be written
    !
    !      BETA_INC(A,B,X) = Integral (0 to X) T^(A-1) * (1-T)^(B-1) dT
    !                      / Integral (0 to 1) T^(A-1) * (1-T)^(B-1) dT
    !
    !    Thus,
    !
    !      BETA_INC(A,B,0.0) = 0.0
    !      BETA_INC(A,B,1.0) = 1.0
    !
    !    Note that in Mathematica, the expressions:
    !
    !      BETA[A,B]   = Integral (0 to 1) T^(A-1) * (1-T)^(B-1) dT
    !      BETA[X,A,B] = Integral (0 to X) T^(A-1) * (1-T)^(B-1) dT
    !
    !    and thus, to evaluate the incomplete Beta function requires:
    !
    !      BETA_INC(A,B,X) = BETA[X,A,B] / BETA[A,B]
    !
    !  Modified:
    !
    !    17 February 2004
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions,
    !    US Department of Commerce, 1964.
    !
    !    Karl Pearson,
    !    Tables of the Incomplete Beta Function,
    !    Cambridge University Press, 1968.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) N_DATA.  The user sets N_DATA to 0
    !    before the first call.  On each call, the routine increments N_DATA by 1,
    !    and returns the corresponding data; when there is no more data, the
    !    output value of N_DATA will be 0 again.
    !
    !    Output, real ( kind = 8 ) A, B, X, the arguments of the function.
    !
    !    Output, real ( kind = 8 ) FX, the value of the function.
    !
    implicit none

    integer ( kind = 4 ), parameter :: n_max = 30

    real ( kind = 8 ) a
    real ( kind = 8 ), save, dimension ( n_max ) :: a_vec = (/ &
        0.5D+00,  0.5D+00,  0.5D+00,  1.0D+00, &
        1.0D+00,  1.0D+00,  1.0D+00,  1.0D+00, &
        2.0D+00,  2.0D+00,  2.0D+00,  2.0D+00, &
        2.0D+00,  2.0D+00,  2.0D+00,  2.0D+00, &
        2.0D+00,  5.5D+00, 10.0D+00, 10.0D+00, &
        10.0D+00, 10.0D+00, 20.0D+00, 20.0D+00, &
        20.0D+00, 20.0D+00, 20.0D+00, 30.0D+00, &
        30.0D+00, 40.0D+00 /)
    real ( kind = 8 ) b
    real ( kind = 8 ), save, dimension ( n_max ) :: b_vec = (/ &
        0.5D+00,  0.5D+00,  0.5D+00,  0.5D+00, &
        0.5D+00,  0.5D+00,  0.5D+00,  1.0D+00, &
        2.0D+00,  2.0D+00,  2.0D+00,  2.0D+00, &
        2.0D+00,  2.0D+00,  2.0D+00,  2.0D+00, &
        2.0D+00,  5.0D+00,  0.5D+00,  5.0D+00, &
        5.0D+00, 10.0D+00,  5.0D+00, 10.0D+00, &
        10.0D+00, 20.0D+00, 20.0D+00, 10.0D+00, &
        10.0D+00, 20.0D+00 /)
    real ( kind = 8 ) fx
    real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ &
        0.0637686D+00, 0.2048328D+00, 1.0000000D+00, 0.0D+00,       &
        0.0050126D+00, 0.0513167D+00, 0.2928932D+00, 0.5000000D+00, &
        0.028D+00,     0.104D+00,     0.216D+00,     0.352D+00,     &
        0.500D+00,     0.648D+00,     0.784D+00,     0.896D+00,     &
        0.972D+00,     0.4361909D+00, 0.1516409D+00, 0.0897827D+00, &
        1.0000000D+00, 0.5000000D+00, 0.4598773D+00, 0.2146816D+00, &
        0.9507365D+00, 0.5000000D+00, 0.8979414D+00, 0.2241297D+00, &
        0.7586405D+00, 0.7001783D+00 /)
    integer ( kind = 4 ) n_data
    real ( kind = 8 ) x
    real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ &
        0.01D+00, 0.10D+00, 1.00D+00, 0.0D+00,  &
        0.01D+00, 0.10D+00, 0.50D+00, 0.50D+00, &
        0.1D+00,  0.2D+00,  0.3D+00,  0.4D+00,  &
        0.5D+00,  0.6D+00,  0.7D+00,  0.8D+00,  &
        0.9D+00,  0.50D+00, 0.90D+00, 0.50D+00, &
        1.00D+00, 0.50D+00, 0.80D+00, 0.60D+00, &
        0.80D+00, 0.50D+00, 0.60D+00, 0.70D+00, &
        0.80D+00, 0.70D+00 /)

    if ( n_data < 0 ) then
        n_data = 0
    end if

    n_data = n_data + 1

    if ( n_max < n_data ) then
        n_data = 0
        a = 0.0D+00
        b = 0.0D+00
        x = 0.0D+00
        fx = 0.0D+00
    else
        a = a_vec(n_data)
        b = b_vec(n_data)
        x = x_vec(n_data)
        fx = fx_vec(n_data)
    end if

    return
    end
    function beta_log ( a0, b0 )

    !*****************************************************************************80
    !
    !! BETA_LOG evaluates the logarithm of the beta function.
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A0, B0, the parameters of the function.
    !    A0 and B0 should be nonnegative.
    !
    !    Output, real ( kind = 8 ) BETA_LOG, the value of the logarithm
    !    of the Beta function.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) a0
    real ( kind = 8 ) algdiv
    real ( kind = 8 ) alnrel
    real ( kind = 8 ) b
    real ( kind = 8 ) b0
    real ( kind = 8 ) bcorr
    real ( kind = 8 ) beta_log
    real ( kind = 8 ) c
    real ( kind = 8 ), parameter :: e = 0.918938533204673D+00
    real ( kind = 8 ) gamma_log
    real ( kind = 8 ) gsumln
    real ( kind = 8 ) h
    integer ( kind = 4 ) i
    integer ( kind = 4 ) n
    real ( kind = 8 ) u
    real ( kind = 8 ) v
    real ( kind = 8 ) w
    real ( kind = 8 ) z

    a = min ( a0, b0 )
    b = max ( a0, b0 )
    !
    !  8 < A.
    !
    if ( 8.0D+00 <= a ) then

        w = bcorr ( a, b )
        h = a / b
        c = h / ( 1.0D+00 + h )
        u = - ( a - 0.5D+00 ) * log ( c )
        v = b * alnrel ( h )

        if ( v < u ) then
            beta_log = ((( -0.5D+00 * log ( b ) + e ) + w ) - v ) - u
        else
            beta_log = ((( -0.5D+00 * log ( b ) + e ) + w ) - u ) - v
        end if

        return
    end if
    !
    !  Procedure when A < 1
    !
    if ( a < 1.0D+00 ) then

        if ( b < 8.0D+00 ) then
            beta_log = gamma_log ( a ) + ( gamma_log ( b ) - gamma_log ( a + b ) )
        else
            beta_log = gamma_log ( a ) + algdiv ( a, b )
        end if

        return

    end if
    !
    !  Procedure when 1 <= A < 8
    !
    if ( 2.0D+00 < a ) then
        go to 40
    end if

    if ( b <= 2.0D+00 ) then
        beta_log = gamma_log ( a ) + gamma_log ( b ) - gsumln ( a, b )
        return
    end if

    w = 0.0D+00

    if ( b < 8.0D+00 ) then
        go to 60
    end if

    beta_log = gamma_log ( a ) + algdiv ( a, b )
    return

40  continue
    !
    !  Reduction of A when 1000 < B.
    !
    if ( 1000.0D+00 < b ) then

        n = a - 1.0D+00
        w = 1.0D+00
        do i = 1, n
            a = a - 1.0D+00
            w = w * ( a / ( 1.0D+00 + a / b ))
        end do

        beta_log = ( log ( w ) - n * log ( b ) ) &
            + ( gamma_log ( a ) + algdiv ( a, b ) )

        return
    end if

    n = a - 1.0D+00
    w = 1.0D+00
    do i = 1, n
        a = a - 1.0D+00
        h = a / b
        w = w * ( h / ( 1.0D+00 + h ) )
    end do
    w = log ( w )

    if ( 8.0D+00 <= b ) then
        beta_log = w + gamma_log ( a ) + algdiv ( a, b )
        return
    end if
    !
    !  Reduction of B when B < 8.
    !
60  continue

    n = b - 1.0D+00
    z = 1.0D+00
    do i = 1, n
        b = b - 1.0D+00
        z = z * ( b / ( a + b ))
    end do

    beta_log = w + log ( z ) + ( gamma_log ( a ) + ( gamma_log ( b ) &
        - gsumln ( a, b ) ) )

    return
    end
    function beta_pser ( a, b, x, eps )

    !*****************************************************************************80
    !
    !! BETA_PSER uses a power series expansion to evaluate IX(A,B)(X).
    !
    !  Discussion:
    !
    !    BETA_PSER is used when B <= 1 or B*X <= 0.7.
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, B, the parameters.
    !
    !    Input, real ( kind = 8 ) X, the point where the function
    !    is to be evaluated.
    !
    !    Input, real ( kind = 8 ) EPS, the tolerance.
    !
    !    Output, real ( kind = 8 ) BETA_PSER, the approximate value of IX(A,B)(X).
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) a0
    real ( kind = 8 ) algdiv
    real ( kind = 8 ) apb
    real ( kind = 8 ) b
    real ( kind = 8 ) b0
    real ( kind = 8 ) beta_log
    real ( kind = 8 ) beta_pser
    real ( kind = 8 ) c
    real ( kind = 8 ) eps
    real ( kind = 8 ) gam1
    real ( kind = 8 ) gamma_ln1
    integer ( kind = 4 ) i
    integer ( kind = 4 ) m
    real ( kind = 8 ) n
    real ( kind = 8 ) sum1
    real ( kind = 8 ) t
    real ( kind = 8 ) tol
    real ( kind = 8 ) u
    real ( kind = 8 ) w
    real ( kind = 8 ) x
    real ( kind = 8 ) z

    beta_pser = 0.0D+00

    if ( x == 0.0D+00 ) then
        return
    end if
    !
    !  Compute the factor X**A/(A*BETA(A,B))
    !
    a0 = min ( a, b )

    if ( 1.0D+00 <= a0 ) then

        z = a * log ( x ) - beta_log ( a, b )
        beta_pser = exp ( z ) / a

    else

        b0 = max ( a, b )

        if ( b0 <= 1.0D+00 ) then

            beta_pser = x**a
            if ( beta_pser == 0.0D+00 ) then
                return
            end if

            apb = a + b

            if ( apb <= 1.0D+00 ) then
                z = 1.0D+00 + gam1 ( apb )
            else
                u = a + b - 1.0D+00
                z = ( 1.0D+00 + gam1 ( u ) ) / apb
            end if

            c = ( 1.0D+00 + gam1 ( a ) ) &
                * ( 1.0D+00 + gam1 ( b ) ) / z
            beta_pser = beta_pser * c * ( b / apb )

        else if ( b0 < 8.0D+00 ) then

            u = gamma_ln1 ( a0 )
            m = b0 - 1.0D+00

            c = 1.0D+00
            do i = 1, m
                b0 = b0 - 1.0D+00
                c = c * ( b0 / ( a0 + b0 ))
            end do

            u = log ( c ) + u
            z = a * log ( x ) - u
            b0 = b0 - 1.0D+00
            apb = a0 + b0

            if ( apb <= 1.0D+00 ) then
                t = 1.0D+00 + gam1 ( apb )
            else
                u = a0 + b0 - 1.0D+00
                t = ( 1.0D+00 + gam1 ( u ) ) / apb
            end if

            beta_pser = exp ( z ) * ( a0 / a ) &
                * ( 1.0D+00 + gam1 ( b0 )) / t

        else if ( 8.0D+00 <= b0 ) then

            u = gamma_ln1 ( a0 ) + algdiv ( a0, b0 )
            z = a * log ( x ) - u
            beta_pser = ( a0 / a ) * exp ( z )

        end if

    end if

    if ( beta_pser == 0.0D+00 .or. a <= 0.1D+00 * eps ) then
        return
    end if
    !
    !  Compute the series.
    !
    sum1 = 0.0D+00
    n = 0.0D+00
    c = 1.0D+00
    tol = eps / a

    do

        n = n + 1.0D+00
        c = c * ( 0.5D+00 + ( 0.5D+00 - b / n ) ) * x
        w = c / ( a + n )
        sum1 = sum1 + w

        if ( abs ( w ) <= tol ) then
            exit
        end if

    end do

    beta_pser = beta_pser * ( 1.0D+00 + a * sum1 )

    return
    end
    function beta_rcomp ( a, b, x, y )

    !*****************************************************************************80
    !
    !! BETA_RCOMP evaluates X^A * Y^B / Beta(A,B).
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, B, the parameters of the Beta function.
    !    A and B should be nonnegative.
    !
    !    Input, real ( kind = 8 ) X, Y, define the numerator of the fraction.
    !
    !    Output, real ( kind = 8 ) BETA_RCOMP, the value of X^A * Y^B / Beta(A,B).
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) a0
    real ( kind = 8 ) algdiv
    real ( kind = 8 ) alnrel
    real ( kind = 8 ) apb
    real ( kind = 8 ) b
    real ( kind = 8 ) b0
    real ( kind = 8 ) bcorr
    real ( kind = 8 ) beta_log
    real ( kind = 8 ) beta_rcomp
    real ( kind = 8 ) c
    real ( kind = 8 ), parameter :: const = 0.398942280401433D+00
    real ( kind = 8 ) e
    real ( kind = 8 ) gam1
    real ( kind = 8 ) gamma_ln1
    real ( kind = 8 ) h
    integer ( kind = 4 ) i
    real ( kind = 8 ) lambda
    real ( kind = 8 ) lnx
    real ( kind = 8 ) lny
    integer ( kind = 4 ) n
    real ( kind = 8 ) rlog1
    real ( kind = 8 ) t
    real ( kind = 8 ) u
    real ( kind = 8 ) v
    real ( kind = 8 ) x
    real ( kind = 8 ) x0
    real ( kind = 8 ) y
    real ( kind = 8 ) y0
    real ( kind = 8 ) z

    beta_rcomp = 0.0D+00
    if ( x == 0.0D+00 .or. y == 0.0D+00 ) then
        return
    end if

    a0 = min ( a, b )

    if ( a0 < 8.0D+00 ) then

        if ( x <= 0.375D+00 ) then
            lnx = log ( x )
            lny = alnrel ( - x )
        else if ( y <= 0.375D+00 ) then
            lnx = alnrel ( - y )
            lny = log ( y )
        else
            lnx = log ( x )
            lny = log ( y )
        end if

        z = a * lnx + b * lny

        if ( 1.0D+00 <= a0 ) then
            z = z - beta_log ( a, b )
            beta_rcomp = exp ( z )
            return
        end if
        !
        !  Procedure for A < 1 or B < 1
        !
        b0 = max ( a, b )

        if ( b0 <= 1.0D+00 ) then

            beta_rcomp = exp ( z )
            if ( beta_rcomp == 0.0D+00 ) then
                return
            end if

            apb = a + b

            if ( apb <= 1.0D+00 ) then
                z = 1.0D+00 + gam1 ( apb )
            else
                u = a + b - 1.0D+00
                z = ( 1.0D+00 + gam1 ( u ) ) / apb
            end if

            c = ( 1.0D+00 + gam1 ( a ) ) &
                * ( 1.0D+00 + gam1 ( b ) ) / z
            beta_rcomp = beta_rcomp * ( a0 * c ) &
                / ( 1.0D+00 + a0 / b0 )

        else if ( b0 < 8.0D+00 ) then

            u = gamma_ln1 ( a0 )
            n = b0 - 1.0D+00

            c = 1.0D+00
            do i = 1, n
                b0 = b0 - 1.0D+00
                c = c * ( b0 / ( a0 + b0 ))
            end do
            u = log ( c ) + u

            z = z - u
            b0 = b0 - 1.0D+00
            apb = a0 + b0

            if ( apb <= 1.0D+00 ) then
                t = 1.0D+00 + gam1 ( apb )
            else
                u = a0 + b0 - 1.0D+00
                t = ( 1.0D+00 + gam1 ( u ) ) / apb
            end if

            beta_rcomp = a0 * exp ( z ) * ( 1.0D+00 + gam1 ( b0 ) ) / t

        else if ( 8.0D+00 <= b0 ) then

            u = gamma_ln1 ( a0 ) + algdiv ( a0, b0 )
            beta_rcomp = a0 * exp ( z - u )

        end if

    else

        if ( a <= b ) then
            h = a / b
            x0 = h / ( 1.0D+00 + h )
            y0 = 1.0D+00 / (  1.0D+00 + h )
            lambda = a - ( a + b ) * x
        else
            h = b / a
            x0 = 1.0D+00 / ( 1.0D+00 + h )
            y0 = h / ( 1.0D+00 + h )
            lambda = ( a + b ) * y - b
        end if

        e = -lambda / a

        if ( abs ( e ) <= 0.6D+00 ) then
            u = rlog1 ( e )
        else
            u = e - log ( x / x0 )
        end if

        e = lambda / b

        if ( abs ( e ) <= 0.6D+00 ) then
            v = rlog1 ( e )
        else
            v = e - log ( y / y0 )
        end if

        z = exp ( - ( a * u + b * v ) )
        beta_rcomp = const * sqrt ( b * x0 ) * z * exp ( - bcorr ( a, b ))

    end if

    return
    end
    function beta_rcomp1 ( mu, a, b, x, y )

    !*****************************************************************************80
    !
    !! BETA_RCOMP1 evaluates exp(MU) * X^A * Y^B / Beta(A,B).
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) MU, ?
    !
    !    Input, real ( kind = 8 ) A, B, the parameters of the Beta function.
    !    A and B should be nonnegative.
    !
    !    Input, real ( kind = 8 ) X, Y, quantities whose powers form part of
    !    the expression.
    !
    !    Output, real ( kind = 8 ) BETA_RCOMP1, the value of
    !    exp(MU) * X**A * Y**B / Beta(A,B).
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) a0
    real ( kind = 8 ) algdiv
    real ( kind = 8 ) alnrel
    real ( kind = 8 ) apb
    real ( kind = 8 ) b
    real ( kind = 8 ) b0
    real ( kind = 8 ) bcorr
    real ( kind = 8 ) beta_log
    real ( kind = 8 ) beta_rcomp1
    real ( kind = 8 ) c
    real ( kind = 8 ), parameter :: const = 0.398942280401433D+00
    real ( kind = 8 ) e
    real ( kind = 8 ) esum
    real ( kind = 8 ) gam1
    real ( kind = 8 ) gamma_ln1
    real ( kind = 8 ) h
    integer ( kind = 4 ) i
    real ( kind = 8 ) lambda
    real ( kind = 8 ) lnx
    real ( kind = 8 ) lny
    integer ( kind = 4 ) mu
    integer ( kind = 4 ) n
    real ( kind = 8 ) rlog1
    real ( kind = 8 ) t
    real ( kind = 8 ) u
    real ( kind = 8 ) v
    real ( kind = 8 ) x
    real ( kind = 8 ) x0
    real ( kind = 8 ) y
    real ( kind = 8 ) y0
    real ( kind = 8 ) z

    a0 = min ( a, b )
    !
    !  Procedure for 8 <= A and 8 <= B.
    !
    if ( 8.0D+00 <= a0 ) then

        if ( a <= b ) then
            h = a / b
            x0 = h / ( 1.0D+00 + h )
            y0 = 1.0D+00 / ( 1.0D+00 + h )
            lambda = a - ( a + b ) * x
        else
            h = b / a
            x0 = 1.0D+00 / ( 1.0D+00 + h )
            y0 = h / ( 1.0D+00 + h )
            lambda = ( a + b ) * y - b
        end if

        e = -lambda / a

        if ( abs ( e ) <= 0.6D+00 ) then
            u = rlog1 ( e )
        else
            u = e - log ( x / x0 )
        end if

        e = lambda / b

        if ( abs ( e ) <= 0.6D+00 ) then
            v = rlog1 ( e )
        else
            v = e - log ( y / y0 )
        end if

        z = esum ( mu, - ( a * u + b * v ))
        beta_rcomp1 = const * sqrt ( b * x0 ) * z * exp ( - bcorr ( a, b ) )
        !
        !  Procedure for A < 8 or B < 8.
        !
    else

        if ( x <= 0.375D+00 ) then
            lnx = log ( x )
            lny = alnrel ( - x )
        else if ( y <= 0.375D+00 ) then
            lnx = alnrel ( - y )
            lny = log ( y )
        else
            lnx = log ( x )
            lny = log ( y )
        end if

        z = a * lnx + b * lny

        if ( 1.0D+00 <= a0 ) then
            z = z - beta_log ( a, b )
            beta_rcomp1 = esum ( mu, z )
            return
        end if
        !
        !  Procedure for A < 1 or B < 1.
        !
        b0 = max ( a, b )

        if ( 8.0D+00 <= b0 ) then
            u = gamma_ln1 ( a0 ) + algdiv ( a0, b0 )
            beta_rcomp1 = a0 * esum ( mu, z-u )
            return
        end if

        if ( 1.0D+00 < b0 ) then
            !
            !  Algorithm for 1 < B0 < 8
            !
            u = gamma_ln1 ( a0 )
            n = b0 - 1.0D+00

            c = 1.0D+00
            do i = 1, n
                b0 = b0 - 1.0D+00
                c = c * ( b0 / ( a0 + b0 ) )
            end do
            u = log ( c ) + u

            z = z - u
            b0 = b0 - 1.0D+00
            apb = a0 + b0

            if ( apb <= 1.0D+00 ) then
                t = 1.0D+00 + gam1 ( apb )
            else
                u = a0 + b0 - 1.0D+00
                t = ( 1.0D+00 + gam1 ( u ) ) / apb
            end if

            beta_rcomp1 = a0 * esum ( mu, z ) &
                * ( 1.0D+00 + gam1 ( b0 ) ) / t
            !
            !  Algorithm for B0 <= 1
            !
        else

            beta_rcomp1 = esum ( mu, z )
            if ( beta_rcomp1 == 0.0D+00 ) then
                return
            end if

            apb = a + b

            if ( apb <= 1.0D+00 ) then
                z = 1.0D+00 + gam1 ( apb )
            else
                u = real ( a, kind = 8 ) + real ( b, kind = 8 ) - 1.0D+00
                z = ( 1.0D+00 + gam1 ( u )) / apb
            end if

            c = ( 1.0D+00 + gam1 ( a ) ) &
                * ( 1.0D+00 + gam1 ( b ) ) / z
            beta_rcomp1 = beta_rcomp1 * ( a0 * c ) / ( 1.0D+00 + a0 / b0 )

        end if

    end if

    return
    end
    function beta_up ( a, b, x, y, n, eps )

    !*****************************************************************************80
    !
    !! BETA_UP evaluates IX(A,B) - IX(A+N,B) where N is a positive integer.
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, B, the parameters of the function.
    !    A and B should be nonnegative.
    !
    !    Input, real ( kind = 8 ) X, Y, ?
    !
    !    Input, integer ( kind = 4 ) N, the increment to the first argument of IX.
    !
    !    Input, real ( kind = 8 ) EPS, the tolerance.
    !
    !    Output, real ( kind = 8 ) BETA_UP, the value of IX(A,B) - IX(A+N,B).
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) ap1
    real ( kind = 8 ) apb
    real ( kind = 8 ) b
    real ( kind = 8 ) beta_rcomp1
    real ( kind = 8 ) beta_up
    real ( kind = 8 ) d
    real ( kind = 8 ) eps
    real ( kind = 8 ) exparg
    integer ( kind = 4 ) i
    integer ( kind = 4 ) k
    real ( kind = 8 ) l
    integer ( kind = 4 ) mu
    integer ( kind = 4 ) n
    real ( kind = 8 ) r
    real ( kind = 8 ) t
    real ( kind = 8 ) w
    real ( kind = 8 ) x
    real ( kind = 8 ) y
    !
    !  Obtain the scaling factor EXP(-MU) AND
    !  EXP(MU)*(X**A*Y**B/BETA(A,B))/A
    !
    apb = a + b
    ap1 = a + 1.0D+00
    mu = 0
    d = 1.0D+00

    if ( n /= 1 ) then

        if ( 1.0D+00 <= a ) then

            if ( 1.1D+00 * ap1 <= apb ) then
                mu = abs ( exparg ( 1 ) )
                k = exparg ( 0 )
                if ( k < mu ) then
                    mu = k
                end if
                t = mu
                d = exp ( - t )
            end if

        end if

    end if

    beta_up = beta_rcomp1 ( mu, a, b, x, y ) / a

    if ( n == 1 .or. beta_up == 0.0D+00 ) then
        return
    end if

    w = d
    !
    !  Let K be the index of the maximum term.
    !
    k = 0

    if ( 1.0D+00 < b ) then

        if ( y <= 0.0001D+00 ) then

            k = n - 1

        else

            r = ( b - 1.0D+00 ) * x / y - a

            if ( 1.0D+00 <= r ) then
                k = n - 1
                t = n - 1
                if ( r < t ) then
                    k = r
                end if
            end if

        end if
        !
        !  Add the increasing terms of the series.
        !
        do i = 1, k
            l = i - 1
            d = ( ( apb + l ) / ( ap1 + l ) ) * x * d
            w = w + d
        end do

    end if
    !
    !  Add the remaining terms of the series.
    !
    do i = k+1, n-1
        l = i - 1
        d = ( ( apb + l ) / ( ap1 + l ) ) * x * d
        w = w + d
        if ( d <= eps * w ) then
            beta_up = beta_up * w
            return
        end if
    end do

    beta_up = beta_up * w

    return
    end
    subroutine binomial_cdf_values ( n_data, a, b, x, fx )

    !*****************************************************************************80
    !
    !! BINOMIAL_CDF_VALUES returns some values of the binomial CDF.
    !
    !  Discussion:
    !
    !    CDF(X)(A,B) is the probability of at most X successes in A trials,
    !    given that the probability of success on a single trial is B.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    27 May 2001
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions,
    !    US Department of Commerce, 1964.
    !
    !    Daniel Zwillinger,
    !    CRC Standard Mathematical Tables and Formulae,
    !    30th Edition, CRC Press, 1996, pages 651-652.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) N_DATA.  The user sets N_DATA to 0
    !    before the first call.  On each call, the routine increments N_DATA by 1,
    !    and returns the corresponding data; when there is no more data, the
    !    output value of N_DATA will be 0 again.
    !
    !    Output, integer ( kind = 4 ) A, real ( kind = 8 ) B, integer X, the
    !    arguments of the function.
    !
    !    Output, real ( kind = 8 ) FX, the value of the function.
    !
    implicit none

    integer ( kind = 4 ), parameter :: n_max = 17

    integer ( kind = 4 ) a
    integer ( kind = 4 ), save, dimension ( n_max ) :: a_vec = (/ &
        2,  2,  2,  2, &
        2,  4,  4,  4, &
        4, 10, 10, 10, &
        10, 10, 10, 10, &
        10 /)
    real ( kind = 8 ) b
    real ( kind = 8 ), save, dimension ( n_max ) :: b_vec = (/ &
        0.05D+00, 0.05D+00, 0.05D+00, 0.50D+00, &
        0.50D+00, 0.25D+00, 0.25D+00, 0.25D+00, &
        0.25D+00, 0.05D+00, 0.10D+00, 0.15D+00, &
        0.20D+00, 0.25D+00, 0.30D+00, 0.40D+00, &
        0.50D+00 /)
    real ( kind = 8 ) fx
    real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ &
        0.9025D+00, 0.9975D+00, 1.0000D+00, 0.2500D+00, &
        0.7500D+00, 0.3164D+00, 0.7383D+00, 0.9492D+00, &
        0.9961D+00, 0.9999D+00, 0.9984D+00, 0.9901D+00, &
        0.9672D+00, 0.9219D+00, 0.8497D+00, 0.6331D+00, &
        0.3770D+00 /)
    integer ( kind = 4 ) n_data
    integer ( kind = 4 ) x
    integer ( kind = 4 ), save, dimension ( n_max ) :: x_vec = (/ &
        0, 1, 2, 0, &
        1, 0, 1, 2, &
        3, 4, 4, 4, &
        4, 4, 4, 4, &
        4 /)

    if ( n_data < 0 ) then
        n_data = 0
    end if

    n_data = n_data + 1

    if ( n_max < n_data ) then
        n_data = 0
        a = 0
        b = 0.0D+00
        x = 0
        fx = 0.0D+00
    else
        a = a_vec(n_data)
        b = b_vec(n_data)
        x = x_vec(n_data)
        fx = fx_vec(n_data)
    end if

    return
    end
    subroutine cdfbet ( which, p, q, x, y, a, b, status, bound )

    !*****************************************************************************80
    !
    !! CDFBET evaluates the CDF of the Beta Distribution.
    !
    !  Discussion:
    !
    !    This routine calculates any one parameter of the beta distribution
    !    given the others.
    !
    !    The value P of the cumulative distribution function is calculated
    !    directly by code associated with the reference.
    !
    !    Computation of the other parameters involves a seach for a value that
    !    produces the desired value of P.  The search relies on the
    !    monotonicity of P with respect to the other parameters.
    !
    !    The beta density is proportional to t^(A-1) * (1-t)^(B-1).
    !
    !  Modified:
    !
    !    14 April 2007
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) WHICH, indicates which of the next four
    !    argument values is to be calculated from the others.
    !    1: Calculate P and Q from X, Y, A and B;
    !    2: Calculate X and Y from P, Q, A and B;
    !    3: Calculate A from P, Q, X, Y and B;
    !    4: Calculate B from P, Q, X, Y and A.
    !
    !    Input/output, real ( kind = 8 ) P, the integral from 0 to X of the
    !    chi-square distribution.  Input range: [0, 1].
    !
    !    Input/output, real ( kind = 8 ) Q, equals 1-P.  Input range: [0, 1].
    !
    !    Input/output, real ( kind = 8 ) X, the upper limit of integration
    !    of the beta density.  If it is an input value, it should lie in
    !    the range [0,1].  If it is an output value, it will be searched for
    !    in the range [0,1].
    !
    !    Input/output, real ( kind = 8 ) Y, equal to 1-X.  If it is an input
    !    value, it should lie in the range [0,1].  If it is an output value,
    !    it will be searched for in the range [0,1].
    !
    !    Input/output, real ( kind = 8 ) A, the first parameter of the beta
    !    density.  If it is an input value, it should lie in the range
    !    (0, +infinity).  If it is an output value, it will be searched
    !    for in the range [1D-300,1D300].
    !
    !    Input/output, real ( kind = 8 ) B, the second parameter of the beta
    !    density.  If it is an input value, it should lie in the range
    !    (0, +infinity).  If it is an output value, it will be searched
    !    for in the range [1D-300,1D300].
    !
    !    Output, integer ( kind = 4 ) STATUS, reports the status of the computation.
    !     0, if the calculation completed correctly;
    !    -I, if the input parameter number I is out of range;
    !    +1, if the answer appears to be lower than lowest search bound;
    !    +2, if the answer appears to be higher than greatest search bound;
    !    +3, if P + Q /= 1;
    !    +4, if X + Y /= 1.
    !
    !    Output, real ( kind = 8 ) BOUND, is only defined if STATUS is nonzero.
    !    If STATUS is negative, then this is the value exceeded by parameter I.
    !    if STATUS is 1 or 2, this is the search bound that was exceeded.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ), parameter :: atol = 1.0D-10
    real ( kind = 8 ) b
    real ( kind = 8 ) bound
    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) fx
    real ( kind = 8 ), parameter :: inf = 1.0D+300
    real ( kind = 8 ) p
    real ( kind = 8 ) q
    logical qhi
    logical qleft
    integer ( kind = 4 ) status
    real ( kind = 8 ), parameter :: tol = 1.0D-08
    integer ( kind = 4 ) which
    real ( kind = 8 ) x
    real ( kind = 8 ) xhi
    real ( kind = 8 ) xlo
    real ( kind = 8 ) y

    status = 0
    bound = 0.0D+00

    if ( which < 1 ) then
        bound = 1.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFBET - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 4.'
        return
    end if

    if ( 4 < which ) then
        bound = 4.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFBET - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 4.'
        return
    end if
    !
    !  Unless P is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( p < 0.0D+00 ) then
            bound = 0.0D+00
            status = -2
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        else if ( 1.0D+00 < p ) then
            bound = 1.0D+00
            status = -2
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        end if
    end if
    !
    !  Unless Q is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( q < 0.0D+00 ) then
            bound = 0.0D+00
            status = -3
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        else if ( 1.0D+00 < q ) then
            bound = 1.0D+00
            status = -3
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        end if
    end if
    !
    !  Unless X is to be computed, make sure it is legal.
    !
    if ( which /= 2 ) then
        if ( x < 0.0D+00 ) then
            bound = 0.0D+00
            status = -4
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter X is out of range.'
            return
        else if ( 1.0D+00 < x ) then
            bound = 1.0D+00
            status = -4
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter X is out of range.'
            return
        end if
    end if
    !
    !  Unless Y is to be computed, make sure it is legal.
    !
    if ( which /= 2 ) then
        if ( y < 0.0D+00 ) then
            bound = 0.0D+00
            status = -5
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Y is out of range.'
            return
        else if ( 1.0D+00 < y ) then
            bound = 1.0D+00
            status = -5
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Y is out of range.'
            return
        end if
    end if
    !
    !  Unless A is to be computed, make sure it is legal.
    !
    if ( which /= 3 ) then
        if ( a <= 0.0D+00 ) then
            bound = 0.0D+00
            status = -6
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter A is out of range.'
            return
        end if
    end if
    !
    !  Unless B is to be computed, make sure it is legal.
    !
    if ( which /= 4 ) then
        if ( b <= 0.0D+00 ) then
            bound = 0.0D+00
            status = -7
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter B is out of range.'
            return
        end if
    end if
    !
    !  Check that P + Q = 1.
    !
    if ( which /= 1 ) then
        if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then
            status = 3
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  P + Q /= 1.'
            return
        end if
    end if
    !
    !  Check that X + Y = 1.
    !
    if ( which /= 2 ) then
        if ( 3.0D+00 * epsilon ( x ) < abs ( ( x + y ) - 1.0D+00 ) ) then
            status = 4
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  X + Y /= 1.'
            return
        end if
    end if
    !
    !  Compute P and Q.
    !
    if ( which == 1 ) then

        call cumbet ( x, y, a, b, p, q )
        status = 0
        !
        !  Compute X and Y.
        !
    else if ( which == 2 ) then

        call dstzr ( 0.0D+00, 1.0D+00, atol, tol )

        if ( p <= q ) then

            status = 0
            fx = 0.0D+00
            call dzror ( status, x, fx, xlo, xhi, qleft, qhi )
            y = 1.0D+00 - x

            do while ( status == 1 )

                call cumbet ( x, y, a, b, cum, ccum )
                fx = cum - p
                call dzror ( status, x, fx, xlo, xhi, qleft, qhi )
                y = 1.0D+00 - x

            end do

        else

            status = 0
            fx = 0.0D+00
            call dzror ( status, y, fx, xlo, xhi, qleft, qhi )
            x = 1.0D+00 - y

            do while ( status == 1 )

                call cumbet ( x, y, a, b, cum, ccum )
                fx = ccum - q
                call dzror ( status, y, fx, xlo, xhi, qleft, qhi )
                x = 1.0D+00 - y

            end do

        end if

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFBET - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = 1.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFBET - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if
        !
        !  Compute A.
        !
    else if ( which == 3 ) then

        call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        a = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, a, fx, qleft, qhi )

        do while ( status == 1 )

            call cumbet ( x, y, a, b, cum, ccum )

            if ( p <= q ) then
                fx = cum - p
            else
                fx = ccum - q
            end if

            call dinvr ( status, a, fx, qleft, qhi )

        end do

        if ( status == -1 ) then

            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFBET - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFBET - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if

        end if
        !
        !  Compute B.
        !
    else if ( which == 4 ) then

        call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        b = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, b, fx, qleft, qhi )

        do while ( status == 1 )

            call cumbet ( x, y, a, b, cum, ccum )

            if ( p <= q ) then
                fx = cum - p
            else
                fx = ccum - q
            end if

            call dinvr ( status, b, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFBET - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFBET - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if

    end if

    return
    end
    subroutine cdfbin ( which, p, q, s, xn, pr, ompr, status, bound )

    !*****************************************************************************80
    !
    !! CDFBIN evaluates the CDF of the Binomial distribution.
    !
    !  Discussion:
    !
    !    This routine calculates any one parameter of the binomial distribution
    !    given the others.
    !
    !    The value P of the cumulative distribution function is calculated
    !    directly.
    !
    !    Computation of the other parameters involves a seach for a value that
    !    produces the desired value of P.  The search relies on the
    !    monotonicity of P with respect to the other parameters.
    !
    !    P is the probablility of S or fewer successes in XN binomial trials,
    !    each trial having an individual probability of success of PR.
    !
    !  Modified:
    !
    !    14 April 2007
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions
    !    1966, Formula 26.5.24.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) WHICH, indicates which of argument values is to
    !    be calculated from the others.
    !    1: Calculate P and Q from S, XN, PR and OMPR;
    !    2: Calculate S from P, Q, XN, PR and OMPR;
    !    3: Calculate XN from P, Q, S, PR and OMPR;
    !    4: Calculate PR and OMPR from P, Q, S and XN.
    !
    !    Input/output, real ( kind = 8 ) P, the cumulation, from 0 to S,
    !    of the binomial distribution.  If P is an input value, it should
    !    lie in the range [0,1].
    !
    !    Input/output, real ( kind = 8 ) Q, equal to 1-P.  If Q is an input
    !    value, it should lie in the range [0,1].  If Q is an output value,
    !    it will lie in the range [0,1].
    !
    !    Input/output, real ( kind = 8 ) S, the number of successes observed.
    !    Whether this is an input or output value, it should lie in the
    !    range [0,XN].
    !
    !    Input/output, real ( kind = 8 ) XN, the number of binomial trials.
    !    If this is an input value it should lie in the range: (0, +infinity).
    !    If it is an output value it will be searched for in the
    !    range [1.0D-300, 1.0D+300].
    !
    !    Input/output, real ( kind = 8 ) PR, the probability of success in each
    !    binomial trial.  Whether this is an input or output value, it should
    !    lie in the range: [0,1].
    !
    !    Input/output, real ( kind = 8 ) OMPR, equal to 1-PR.  Whether this is an
    !    input or output value, it should lie in the range [0,1].  Also, it should
    !    be the case that PR + OMPR = 1.
    !
    !    Output, integer ( kind = 4 ) STATUS, reports the status of the computation.
    !     0, if the calculation completed correctly;
    !    -I, if the input parameter number I is out of range;
    !    +1, if the answer appears to be lower than lowest search bound;
    !    +2, if the answer appears to be higher than greatest search bound;
    !    +3, if P + Q /= 1;
    !    +4, if PR + OMPR /= 1.
    !
    !    Output, real ( kind = 8 ) BOUND, is only defined if STATUS is nonzero.
    !    If STATUS is negative, then this is the value exceeded by parameter I.
    !    if STATUS is 1 or 2, this is the search bound that was exceeded.
    !
    implicit none

    real ( kind = 8 ), parameter :: atol = 1.0D-10
    real ( kind = 8 ) bound
    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) fx
    real ( kind = 8 ), parameter :: inf = 1.0D+300
    real ( kind = 8 ) ompr
    real ( kind = 8 ) p
    real ( kind = 8 ) pr
    real ( kind = 8 ) q
    logical qhi
    logical qleft
    real ( kind = 8 ) s
    integer ( kind = 4 ) status
    real ( kind = 8 ), parameter :: tol = 1.0D-08
    integer ( kind = 4 ) which
    real ( kind = 8 ) xhi
    real ( kind = 8 ) xlo
    real ( kind = 8 ) xn

    status = 0
    bound = 0.0D+00
    !
    !  Check the arguments.
    !
    if ( which < 1 ) then
        bound = 1.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFBET - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 4.'
        return
    end if

    if ( 4 < which ) then
        bound = 4.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFBET - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 4.'
        return
    end if
    !
    !  Unless P is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( p < 0.0D+00 ) then
            status = -2
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        else if ( 1.0D+00 < p ) then
            status = -2
            bound = 1.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        end if
    end if
    !
    !  Unless Q is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( q < 0.0D+00 ) then
            status = -3
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        else if ( 1.0D+00 < q ) then
            status = -3
            bound = 1.0
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        end if
    end if
    !
    !  Unless XN is to be computed, make sure it is legal.
    !
    if ( which /= 3 ) then
        if ( xn <= 0.0D+00 ) then
            bound = 0.0D+00
            status = -5
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter XN is out of range.'
            return
        end if
    end if
    !
    !  Unless S is to be computed, make sure it is legal.
    !
    if ( which /= 2 ) then
        if ( s < 0.0D+00 ) then
            bound = 0.0D+00
            status = -4
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter S is out of range.'
            return
        else if ( which /= 3 .and. xn < s ) then
            bound = xn
            status = -4
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter S is out of range.'
            return
        end if
    end if
    !
    !  Unless PR is to be computed, make sure it is legal.
    !
    if ( which /= 4 ) then
        if ( pr < 0.0D+00 ) then
            bound = 0.0D+00
            status = -6
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter PR is out of range.'
            return
        else if ( 1.0D+00 < pr ) then
            bound = 1.0D+00
            status = -6
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter PR is out of range.'
            return
        end if
    end if
    !
    !  Unless OMPR is to be computed, make sure it is legal.
    !
    if ( which /= 4 ) then
        if ( ompr < 0.0D+00 ) then
            bound = 0.0D+00
            status = -7
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter OMPR is out of range.'
            return
        else if ( 1.0D+00 < ompr ) then
            bound = 1.0D+00
            status = -7
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  Input parameter OMPR is out of range.'
            return
        end if
    end if
    !
    !  Check that P + Q = 1.
    !
    if ( which /= 1 ) then
        if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then
            status = 3
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  P + Q /= 1.'
            return
        end if
    end if
    !
    !  Check that PR + OMPR = 1.
    !
    if ( which /= 4 ) then
        if ( 3.0D+00 * epsilon ( 1.0D+00 ) &
            < abs ( ( pr + ompr ) - 1.0D+00 ) ) then
            status = 4
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFBET - Fatal error!'
            write ( *, '(a)' ) '  PR + OMPR /= 1.'
            return
        end if
    end if
    !
    !  Calculate P and Q.
    !
    if ( which == 1 ) then

        call cumbin ( s, xn, pr, ompr, p, q )
        status = 0
        !
        !  Calculate S.
        !
    else if ( which == 2 ) then

        call dstinv ( 0.0D+00, xn, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        s = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, s, fx, qleft, qhi )

        do while ( status == 1 )

            call cumbin ( s, xn, pr, ompr, cum, ccum )

            if ( p <= q ) then
                fx = cum - p
            else
                fx = ccum - q
            end if

            call dinvr ( status, s, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFBIN - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = xn
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFBIN - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if
        !
        !  Calculate XN.
        !
    else if ( which == 3 ) then

        call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        xn = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, xn, fx, qleft, qhi )

        do while ( status == 1 )

            call cumbin ( s, xn, pr, ompr, cum, ccum )

            if ( p <= q ) then
                fx = cum - p
            else
                fx = ccum - q
            end if

            call dinvr ( status, xn, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFBIN - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
                return
            else
                status = 2
                bound = inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFBIN - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
                return
            end if
        end if
        !
        !  Calculate PR and OMPR.
        !
    else if ( which == 4 ) then

        call dstzr ( 0.0D+00, 1.0D+00, atol, tol )

        if ( p <= q ) then

            status = 0
            call dzror ( status, pr, fx, xlo, xhi, qleft, qhi )
            ompr = 1.0D+00 - pr

            do while ( status == 1 )

                call cumbin ( s, xn, pr, ompr, cum, ccum )
                fx = cum - p
                call dzror ( status, pr, fx, xlo, xhi, qleft, qhi )
                ompr = 1.0D+00 - pr

            end do

        else

            status = 0
            call dzror ( status, ompr, fx, xlo, xhi, qleft, qhi )
            pr = 1.0D+00 - ompr

            do while ( status == 1 )

                call cumbin ( s, xn, pr, ompr, cum, ccum )
                fx = ccum - q
                call dzror ( status, ompr, fx, xlo, xhi, qleft, qhi )
                pr = 1.0D+00 - ompr

            end do

        end if

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFBIN - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = 1.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFBIN - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if

    end if

    return
    end
    subroutine cdfchi ( which, p, q, x, df, status, bound )

    !*****************************************************************************80
    !
    !! CDFCHI evaluates the CDF of the chi square distribution.
    !
    !  Discussion:
    !
    !    This routine calculates any one parameter of the chi square distribution
    !    given the others.
    !
    !    The value P of the cumulative distribution function is calculated
    !    directly.
    !
    !    Computation of the other parameters involves a seach for a value that
    !    produces the desired value of P.  The search relies on the
    !    monotonicity of P with respect to the other parameters.
    !
    !    The CDF of the chi square distribution can be evaluated
    !    within Mathematica by commands such as:
    !
    !      Needs["Statistics`ContinuousDistributions`"]
    !      CDF [ ChiSquareDistribution [ DF ], X ]
    !
    !  Modified:
    !
    !    14 April 2007
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions
    !    1966, Formula 26.4.19.
    !
    !    Stephen Wolfram,
    !    The Mathematica Book,
    !    Fourth Edition,
    !    Wolfram Media / Cambridge University Press, 1999.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) WHICH, indicates which argument is to be
    !    calculated from the others.
    !    1: Calculate P and Q from X and DF;
    !    2: Calculate X from P, Q and DF;
    !    3: Calculate DF from P, Q and X.
    !
    !    Input/output, real ( kind = 8 ) P, the integral from 0 to X of
    !    the chi-square distribution.  If this is an input value, it should
    !    lie in the range [0,1].
    !
    !    Input/output, real ( kind = 8 ) Q, equal to 1-P.  If Q is an input
    !    value, it should lie in the range [0,1].  If Q is an output value,
    !    it will lie in the range [0,1].
    !
    !    Input/output, real ( kind = 8 ) X, the upper limit of integration
    !    of the chi-square distribution.  If this is an input
    !    value, it should lie in the range: [0, +infinity).  If it is an output
    !    value, it will be searched for in the range: [0,1.0D+300].
    !
    !    Input/output, real ( kind = 8 ) DF, the degrees of freedom of the
    !    chi-square distribution.  If this is an input value, it should lie
    !    in the range: (0, +infinity).  If it is an output value, it will be
    !    searched for in the range: [ 1.0D-300, 1.0D+300].
    !
    !    Output, integer ( kind = 4 ) STATUS, reports the status of the computation.
    !     0, if the calculation completed correctly;
    !    -I, if the input parameter number I is out of range;
    !    +1, if the answer appears to be lower than lowest search bound;
    !    +2, if the answer appears to be higher than greatest search bound;
    !    +3, if P + Q /= 1;
    !    +10, an error was returned from CUMGAM.
    !
    !    Output, real ( kind = 8 ) BOUND, is only defined if STATUS is nonzero.
    !    If STATUS is negative, then this is the value exceeded by parameter I.
    !    if STATUS is 1 or 2, this is the search bound that was exceeded.
    !
    implicit none

    real ( kind = 8 ), parameter :: atol = 1.0D-10
    real ( kind = 8 ) bound
    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) df
    real ( kind = 8 ) fx
    real ( kind = 8 ), parameter :: inf = 1.0D+300
    real ( kind = 8 ) p
    real ( kind = 8 ) porq
    real ( kind = 8 ) q
    logical qhi
    logical qleft
    integer ( kind = 4 ) status
    real ( kind = 8 ), parameter :: tol = 1.0D-08
    integer ( kind = 4 ) which
    real ( kind = 8 ) x

    status = 0
    bound = 0.0D+00
    !
    !  Check the arguments.
    !
    if ( which < 1 ) then
        bound = 1.0
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFCHI - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 3.'
        return
    end if

    if ( 3 < which ) then
        bound = 3.0
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFCHI - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 3.'
        return
    end if
    !
    !  Unless P is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( p < 0.0D+00 ) then
            status = -2
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFCHI - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        else if ( 1.0D+00 < p ) then
            status = -2
            bound = 1.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFCHI - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        end if
    end if
    !
    !  Unless Q is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( q < 0.0D+00 ) then
            status = -3
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFCHI - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        else if ( 1.0D+00 < q ) then
            status = -3
            bound = 1.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFCHI - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        end if
    end if
    !
    !  Unless X is to be computed, make sure it is legal.
    !
    if ( which /= 2 ) then
        if ( x < 0.0D+00 ) then
            bound = 0.0D+00
            status = -4
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFCHI - Fatal error!'
            write ( *, '(a)' ) '  Input parameter X is out of range.'
            return
        end if
    end if
    !
    !  Unless DF is to be computed, make sure it is legal.
    !
    if ( which /= 3 ) then
        if ( df <= 0.0D+00 ) then
            bound = 0.0D+00
            status = -5
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFCHI - Fatal error!'
            write ( *, '(a)' ) '  Input parameter DF is out of range.'
            return
        end if
    end if
    !
    !  Check that P + Q = 1.
    !
    if ( which /= 1 ) then
        if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then
            status = 3
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFCHI - Fatal error!'
            write ( *, '(a)' ) '  P + Q /= 1.'
            return
        end if
    end if
    !
    !  Select the minimum of P and Q.
    !
    if ( which /= 1 ) then
        porq = min ( p, q )
    end if
    !
    !  Calculate P and Q.
    !
    if ( which == 1 ) then

        status = 0
        call cumchi ( x, df, p, q )

        if ( 1.5D+00 < porq ) then
            status = 10
            return
        end if
        !
        !  Calculate X.
        !
    else if ( which == 2 ) then

        call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        x = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, x, fx, qleft, qhi )

        do while ( status == 1 )

            call cumchi ( x, df, cum, ccum )

            if ( p <= q ) then
                fx = cum - p
            else
                fx = ccum - q
            end if

            if ( 1.5D+00 < fx + porq ) then
                status = 10
                return
            end if

            call dinvr ( status, x, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFCHI - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFCHI - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if

        end if
        !
        !  Calculate DF.
        !
    else if ( which == 3 ) then

        call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        df = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, df, fx, qleft, qhi )

        do while ( status == 1 )

            call cumchi ( x, df, cum, ccum )

            if ( p <= q ) then
                fx = cum - p
            else
                fx = ccum - q
            end if

            if ( 1.5D+00 < fx + porq ) then
                status = 10
                return
            end if

            call dinvr ( status, df, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFCHI - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFCHI - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if

    end if

    return
    end
    subroutine cdfchn ( which, p, q, x, df, pnonc, status, bound )

    !*****************************************************************************80
    !
    !! CDFCHN evaluates the CDF of the Noncentral Chi-Square.
    !
    !  Discussion:
    !
    !    This routine calculates any one parameter of the noncentral chi-square
    !    distribution given values for the others.
    !
    !    The value P of the cumulative distribution function is calculated
    !    directly.
    !
    !    Computation of the other parameters involves a seach for a value that
    !    produces the desired value of P.  The search relies on the
    !    monotonicity of P with respect to the other parameters.
    !
    !    The computation time required for this routine is proportional
    !    to the noncentrality parameter (PNONC).  Very large values of
    !    this parameter can consume immense computer resources.  This is
    !    why the search range is bounded by 10,000.
    !
    !    The CDF of the noncentral chi square distribution can be evaluated
    !    within Mathematica by commands such as:
    !
    !      Needs["Statistics`ContinuousDistributions`"]
    !      CDF[ NoncentralChiSquareDistribution [ DF, LAMBDA ], X ]
    !
    !  Modified:
    !
    !    14 April 2007
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions
    !    1966, Formula 26.5.25.
    !
    !    Stephen Wolfram,
    !    The Mathematica Book,
    !    Fourth Edition,
    !    Wolfram Media / Cambridge University Press, 1999.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) WHICH, indicates which argument is to be
    !    calculated from the others.
    !    1: Calculate P and Q from X, DF and PNONC;
    !    2: Calculate X from P, DF and PNONC;
    !    3: Calculate DF from P, X and PNONC;
    !    4: Calculate PNONC from P, X and DF.
    !
    !    Input/output, real ( kind = 8 ) P, the integral from 0 to X of
    !    the noncentral chi-square distribution.  If this is an input
    !    value, it should lie in the range: [0, 1.0-1.0D-16).
    !
    !    Input/output, real ( kind = 8 ) Q, is generally not used by this
    !    subroutine and is only included for similarity with other routines.
    !    However, if P is to be computed, then a value will also be computed
    !    for Q.
    !
    !    Input, real ( kind = 8 ) X, the upper limit of integration of the
    !    noncentral chi-square distribution.  If this is an input value, it
    !    should lie in the range: [0, +infinity).  If it is an output value,
    !    it will be sought in the range: [0,1.0D+300].
    !
    !    Input/output, real ( kind = 8 ) DF, the number of degrees of freedom
    !    of the noncentral chi-square distribution.  If this is an input value,
    !    it should lie in the range: (0, +infinity).  If it is an output value,
    !    it will be searched for in the range: [ 1.0D-300, 1.0D+300].
    !
    !    Input/output, real ( kind = 8 ) PNONC, the noncentrality parameter of
    !    the noncentral chi-square distribution.  If this is an input value, it
    !    should lie in the range: [0, +infinity).  If it is an output value,
    !    it will be searched for in the range: [0,1.0D+4]
    !
    !    Output, integer ( kind = 4 ) STATUS, reports on the calculation.
    !    0, if calculation completed correctly;
    !    -I, if input parameter number I is out of range;
    !    1, if the answer appears to be lower than the lowest search bound;
    !    2, if the answer appears to be higher than the greatest search bound.
    !
    !    Output, real ( kind = 8 ) BOUND, is only defined if STATUS is nonzero.
    !    If STATUS is negative, then this is the value exceeded by parameter I.
    !    if STATUS is 1 or 2, this is the search bound that was exceeded.
    !
    implicit none

    real ( kind = 8 ), parameter :: atol=1.0D-50
    real ( kind = 8 ) bound
    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) df
    real ( kind = 8 ) fx
    real ( kind = 8 ), parameter :: inf=1.0D+300
    real ( kind = 8 ) p
    real ( kind = 8 ) pnonc
    real ( kind = 8 ) q
    logical qhi
    logical qleft
    integer ( kind = 4 ) status
    real ( kind = 8 ), parameter :: tent4=1.0D+04
    real ( kind = 8 ), parameter :: tol=1.0D-08
    integer ( kind = 4 ) which
    real ( kind = 8 ) x

    status = 0
    bound = 0.0D+00
    !
    !  Check the arguments.
    !
    if ( which < 1 ) then
        bound = 1.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFCHN - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 4.'
        return
    end if

    if ( 4 < which ) then
        bound = 4.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFCHN - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 4.'
        return
    end if
    !
    !  Unless P is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( p < 0.0D+00 ) then
            status = -2
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFCHN - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        else if ( 1.0D+00 < p ) then
            status = -2
            bound = 1.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFCHN - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        end if
    end if
    !
    !  Unless X is to be computed, make sure it is legal.
    !
    if ( which /= 2 ) then
        if ( x < 0.0D+00 ) then
            bound = 0.0D+00
            status = -4
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFCHN - Fatal error!'
            write ( *, '(a)' ) '  Input parameter X is out of range.'
            return
        end if
    end if
    !
    !  Unless DF is to be computed, make sure it is legal.
    !
    if ( which /= 3 ) then
        if ( df <= 0.0D+00 ) then
            bound = 0.0D+00
            status = -5
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFCHN - Fatal error!'
            write ( *, '(a)' ) '  Input parameter DF is out of range.'
            return
        end if
    end if
    !
    !  Unless PNONC is to be computed, make sure it is legal.
    !
    if ( which /= 4 ) then
        if ( pnonc < 0.0D+00 ) then
            bound = 0.0D+00
            status = -6
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFCHN - Fatal error!'
            write ( *, '(a)' ) '  Input parameter PNONC is out of range.'
            return
        end if
    end if
    !
    !  Calculate P and Q.
    !
    if ( which == 1 ) then

        call cumchn ( x, df, pnonc, p, q )
        status = 0
        !
        !  Calculate X.
        !
    else if ( which == 2 ) then

        call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        x = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, x, fx, qleft, qhi )

        do while ( status == 1 )

            call cumchn ( x, df, pnonc, cum, ccum )
            fx = cum - p
            call dinvr ( status, x, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFCHN - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFCHN - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if
        !
        !  Calculate DF.
        !
    else if ( which == 3 ) then

        call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        df = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, df, fx, qleft, qhi )

        do while ( status == 1 )

            call cumchn ( x, df, pnonc, cum, ccum )
            fx = cum - p
            call dinvr ( status, df, fx, qleft, qhi )

        end do

        if ( status == -1 )then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFCHN - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFCHN - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if
        !
        !  Calculate PNONC.
        !
    else if ( which == 4 ) then

        call dstinv ( 0.0D+00, tent4, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        pnonc = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, pnonc, fx, qleft, qhi )

        do while ( status == 1 )

            call cumchn ( x, df, pnonc, cum, ccum )
            fx = cum - p
            call dinvr ( status, pnonc, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFCHN - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = tent4
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFCHN - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if

    end if

    return
    end
    subroutine cdff ( which, p, q, f, dfn, dfd, status, bound )

    !*****************************************************************************80
    !
    !! CDFF evaluates the CDF of the F distribution.
    !
    !  Discussion:
    !
    !    This routine calculates any one parameter of the F distribution
    !    given the others.
    !
    !    The value P of the cumulative distribution function is calculated
    !    directly.
    !
    !    Computation of the other parameters involves a seach for a value that
    !    produces the desired value of P.  The search relies on the
    !    monotonicity of P with respect to the other parameters.
    !
    !    The value of the cumulative F distribution is not necessarily
    !    monotone in either degrees of freedom.  There thus may be two
    !    values that provide a given CDF value.  This routine assumes
    !    monotonicity and will find an arbitrary one of the two values.
    !
    !  Modified:
    !
    !    14 April 2007
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions
    !    1966, Formula 26.6.2.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) WHICH, indicates which argument is to be
    !    calculated from the others.
    !    1: Calculate P and Q from F, DFN and DFD;
    !    2: Calculate F from P, Q, DFN and DFD;
    !    3: Calculate DFN from P, Q, F and DFD;
    !    4: Calculate DFD from P, Q, F and DFN.
    !
    !    Input/output, real ( kind = 8 ) P, the integral from 0 to F of
    !    the F-density.  If it is an input value, it should lie in the
    !    range [0,1].
    !
    !    Input/output, real ( kind = 8 ) Q, equal to 1-P.  If Q is an input
    !    value, it should lie in the range [0,1].  If Q is an output value,
    !    it will lie in the range [0,1].
    !
    !    Input/output, real ( kind = 8 ) F, the upper limit of integration
    !    of the F-density.  If this is an input value, it should lie in the
    !    range [0, +infinity).  If it is an output value, it will be searched
    !    for in the range [0,1.0D+300].
    !
    !    Input/output, real ( kind = 8 ) DFN, the number of degrees of
    !    freedom of the numerator sum of squares.  If this is an input value,
    !    it should lie in the range: (0, +infinity).  If it is an output value,
    !    it will be searched for in the range: [ 1.0D-300, 1.0D+300].
    !
    !    Input/output, real ( kind = 8 ) DFD, the number of degrees of freedom
    !    of the denominator sum of squares.  If this is an input value, it should
    !    lie in the range: (0, +infinity).  If it is an output value, it will
    !    be searched for in the  range: [ 1.0D-300, 1.0D+300].
    !
    !    Output, integer ( kind = 4 ) STATUS, reports the status of the computation.
    !     0, if the calculation completed correctly;
    !    -I, if the input parameter number I is out of range;
    !    +1, if the answer appears to be lower than lowest search bound;
    !    +2, if the answer appears to be higher than greatest search bound;
    !    +3, if P + Q /= 1.
    !
    !    Output, real ( kind = 8 ) BOUND, is only defined if STATUS is nonzero.
    !    If STATUS is negative, then this is the value exceeded by parameter I.
    !    if STATUS is 1 or 2, this is the search bound that was exceeded.
    !
    implicit none

    real ( kind = 8 ), parameter :: atol = 1.0D-10
    real ( kind = 8 ) bound
    real ( kind = 8 ) bound_hi
    real ( kind = 8 ) bound_lo
    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) dfd
    real ( kind = 8 ) dfn
    real ( kind = 8 ) f
    real ( kind = 8 ) fx
    real ( kind = 8 ), parameter :: inf = 1.0D+300
    real ( kind = 8 ) p
    real ( kind = 8 ) q
    logical qhi
    logical qleft
    integer ( kind = 4 ) status
    real ( kind = 8 ), parameter :: tol = 1.0D-08
    integer ( kind = 4 ) which

    status = 0
    bound = 0.0D+00
    !
    !  Check the arguments.
    !
    if ( which < 1 ) then
        bound = 1.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFF - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 4.'
        return
    end if

    if ( 4 < which ) then
        bound = 4.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFF - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 4.'
        return
    end if
    !
    !  Unless P is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( p < 0.0D+00 ) then
            status = -2
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFF - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        else if ( 1.0D+00 < p ) then
            status = -2
            bound = 1.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFF - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        end if
    end if
    !
    !  Unless Q is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( q < 0.0D+00 ) then
            status = -3
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFF - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        else if ( 1.0D+00 < q ) then
            status = -3
            bound = 1.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFF - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        end if
    end if
    !
    !  Unless F is to be computed, make sure it is legal.
    !
    if ( which /= 2 ) then
        if ( f < 0.0D+00 ) then
            bound = 0.0D+00
            status = -4
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFF - Fatal error!'
            write ( *, '(a)' ) '  Input parameter F is out of range.'
            return
        end if
    end if
    !
    !  Unless DFN is to be computed, make sure it is legal.
    !
    if ( which /= 3 ) then
        if ( dfn <= 0.0D+00 ) then
            bound = 0.0D+00
            status = -5
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFF - Fatal error!'
            write ( *, '(a)' ) '  Input parameter DFN is out of range.'
            return
        end if
    end if
    !
    !  Unless DFD is to be computed, make sure it is legal.
    !
    if ( which /= 4 ) then
        if ( dfd <= 0.0D+00 ) then
            bound = 0.0D+00
            status = -6
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFF - Fatal error!'
            write ( *, '(a)' ) '  Input parameter DFD is out of range.'
            return
        end if
    end if
    !
    !  Check that P + Q = 1.
    !
    if ( which /= 1 ) then
        if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then
            status = 3
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFF - Fatal error!'
            write ( *, '(a)' ) '  P + Q /= 1.'
            return
        end if
    end if
    !
    !  Calculate P and Q.
    !
    if ( which == 1 ) then

        call cumf ( f, dfn, dfd, p, q )
        status = 0
        !
        !  Calculate F.
        !
    else if ( which == 2 ) then

        call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        f = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, f, fx, qleft, qhi )

        do while ( status == 1 )

            call cumf ( f, dfn, dfd, cum, ccum )

            if ( p <= q ) then
                fx = cum - p
            else
                fx = ccum - q
            end if

            call dinvr ( status, f, fx, qleft, qhi )

        end do

        if ( status == -1 ) then

            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFF - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFF - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if

        end if
        !
        !  Calculate DFN.
        !
        !  Note that, in the original calculation, the lower bound for DFN was 0.
        !  Using DFN = 0 causes an error in CUMF when it calls BETA_INC.
        !  The lower bound was set to the more reasonable value of 1.
        !  JVB, 14 April 2007.
        !
    else if ( which == 3 ) then

        bound_lo = 1.0D+00
        bound_hi = inf

        call dstinv ( bound_lo, bound_hi, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        dfn = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, dfn, fx, qleft, qhi )

        do while ( status == 1 )

            call cumf ( f, dfn, dfd, cum, ccum )

            if ( p <= q ) then
                fx = cum - p
            else
                fx = ccum - q
            end if

            call dinvr ( status, dfn, fx, qleft, qhi )

        end do

        if ( status == -1 ) then

            if ( qleft ) then
                status = 1
                bound = bound_lo
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFF - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound_lo
                return
            else
                status = 2
                bound = bound_hi
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFF - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound_hi
                return
            end if

        end if
        !
        !  Calculate DFD.
        !
        !  Note that, in the original calculation, the lower bound for DFD was 0.
        !  Using DFD = 0 causes an error in CUMF when it calls BETA_INC.
        !  The lower bound was set to the more reasonable value of 1.
        !  JVB, 14 April 2007.
        !
    else if ( which == 4 ) then

        bound_lo = 1.0D+00
        bound_hi = inf

        call dstinv ( bound_lo, bound_hi, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        dfd = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, dfd, fx, qleft, qhi )

        do while ( status == 1 )

            call cumf ( f, dfn, dfd, cum, ccum )

            if ( p <= q ) then
                fx = cum - p
            else
                fx = ccum - q
            end if

            call dinvr ( status, dfd, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = bound_lo
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFF - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound_lo
            else
                status = 2
                bound = bound_hi
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFF - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound_hi
            end if
        end if

    end if

    return
    end
    subroutine cdffnc ( which, p, q, f, dfn, dfd, pnonc, status, bound )

    !*****************************************************************************80
    !
    !! CDFFNC evaluates the CDF of the Noncentral F distribution.
    !
    !  Discussion:
    !
    !    This routine originally used 1.0D+300 as the upper bound for the
    !    interval in which many of the missing parameters are to be sought.
    !    Since the underlying rootfinder routine needs to evaluate the
    !    function at this point, it is no surprise that the program was
    !    experiencing overflows.  A less extravagant upper bound
    !    is being tried for now!
    !
    !    This routine calculates any one parameter of the Noncentral F distribution
    !    given the others.
    !
    !    The value P of the cumulative distribution function is calculated
    !    directly.
    !
    !    Computation of the other parameters involves a seach for a value that
    !    produces the desired value of P.  The search relies on the
    !    monotonicity of P with respect to the other parameters.
    !
    !    The computation time required for this routine is proportional
    !    to the noncentrality parameter PNONC.  Very large values of
    !    this parameter can consume immense computer resources.  This is
    !    why the search range is bounded by 10,000.
    !
    !    The value of the cumulative noncentral F distribution is not
    !    necessarily monotone in either degree of freedom.  There thus
    !    may be two values that provide a given CDF value.  This routine
    !    assumes monotonicity and will find an arbitrary one of the two
    !    values.
    !
    !    The CDF of the noncentral F distribution can be evaluated
    !    within Mathematica by commands such as:
    !
    !      Needs["Statistics`ContinuousDistributions`"]
    !      CDF [ NoncentralFRatioDistribution [ DFN, DFD, PNONC ], X ]
    !
    !  Modified:
    !
    !    14 April 2007
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions
    !    1966, Formula 26.6.20.
    !
    !    Stephen Wolfram,
    !    The Mathematica Book,
    !    Fourth Edition,
    !    Wolfram Media / Cambridge University Press, 1999.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) WHICH, indicates which argument is to be
    !    calculated from the others.
    !    1: Calculate P and Q from F, DFN, DFD and PNONC;
    !    2: Calculate F from P, Q, DFN, DFD and PNONC;
    !    3: Calculate DFN from P, Q, F, DFD and PNONC;
    !    4: Calculate DFD from P, Q, F, DFN and PNONC;
    !    5: Calculate PNONC from P, Q, F, DFN and DFD.
    !
    !    Input/output, real ( kind = 8 ) P, the integral from 0 to F of
    !    the noncentral F-density.  If P is an input value it should
    !    lie in the range [0,1) (Not including 1!).
    !
    !    Dummy, real ( kind = 8 ) Q, is not used by this subroutine,
    !    and is only included for similarity with the other routines.
    !    Its input value is not checked.  If P is to be computed, the
    !    Q is set to 1 - P.
    !
    !    Input/output, real ( kind = 8 ) F, the upper limit of integration
    !    of the noncentral F-density.  If this is an input value, it should
    !    lie in the range: [0, +infinity).  If it is an output value, it
    !    will be searched for in the range: [0,1.0D+30].
    !
    !    Input/output, real ( kind = 8 ) DFN, the number of degrees of freedom
    !    of the numerator sum of squares.  If this is an input value, it should
    !    lie in the range: (0, +infinity).  If it is an output value, it will
    !    be searched for in the range: [ 1.0, 1.0D+30].
    !
    !    Input/output, real ( kind = 8 ) DFD, the number of degrees of freedom
    !    of the denominator sum of squares.  If this is an input value, it should
    !    be in range: (0, +infinity).  If it is an output value, it will be
    !    searched for in the range [1.0, 1.0D+30].
    !
    !    Input/output, real ( kind = 8 ) PNONC, the noncentrality parameter
    !    If this is an input value, it should be nonnegative.
    !    If it is an output value, it will be searched for in the range: [0,1.0D+4].
    !
    !    Output, integer ( kind = 4 ) STATUS, reports the status of the computation.
    !     0, if the calculation completed correctly;
    !    -I, if the input parameter number I is out of range;
    !    +1, if the answer appears to be lower than lowest search bound;
    !    +2, if the answer appears to be higher than greatest search bound;
    !    +3, if P + Q /= 1.
    !
    !    Output, real ( kind = 8 ) BOUND, is only defined if STATUS is nonzero.
    !    If STATUS is negative, then this is the value exceeded by parameter I.
    !    if STATUS is 1 or 2, this is the search bound that was exceeded.
    !
    implicit none

    real ( kind = 8 ), parameter :: atol = 1.0D-10
    real ( kind = 8 ) bound
    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) dfd
    real ( kind = 8 ) dfn
    real ( kind = 8 ) f
    real ( kind = 8 ) fx
    real ( kind = 8 ), parameter :: inf = 1.0D+30
    real ( kind = 8 ) p
    real ( kind = 8 ) pnonc
    real ( kind = 8 ) q
    logical qhi
    logical qleft
    integer ( kind = 4 ) status
    real ( kind = 8 ), parameter :: tent4 = 1.0D+04
    real ( kind = 8 ), parameter :: tol = 1.0D-08
    integer ( kind = 4 ) which

    status = 0
    bound = 0.0D+00
    !
    !  Check the arguments.
    !
    if ( which < 1 ) then
        bound = 1.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFFNC - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 5.'
        return
    end if

    if ( 5 < which ) then
        bound = 5.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFFNC - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 5.'
        return
    end if
    !
    !  Unless P is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( p < 0.0D+00 ) then
            status = -2
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFFNC - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        else if ( 1.0D+00 < p ) then
            status = -2
            bound = 1.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFFNC - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        end if
    end if
    !
    !  Unless F is to be computed, make sure it is legal.
    !
    if ( which /= 2 ) then
        if ( f < 0.0D+00 ) then
            bound = 0.0D+00
            status = -4
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFFNC - Fatal error!'
            write ( *, '(a)' ) '  Input parameter F is out of range.'
            return
        end if
    end if
    !
    !  Unless DFN is to be computed, make sure it is legal.
    !
    if ( which /= 3 ) then
        if ( dfn <= 0.0D+00 ) then
            bound = 0.0D+00
            status = -5
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFFNC - Fatal error!'
            write ( *, '(a)' ) '  Input parameter DFN is out of range.'
            return
        end if
    end if
    !
    !  Unless DFD is to be computed, make sure it is legal.
    !
    if ( which /= 4 ) then
        if ( dfd <= 0.0D+00 ) then
            bound = 0.0D+00
            status = -6
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFFNC - Fatal error!'
            write ( *, '(a)' ) '  Input parameter DFD is out of range.'
            return
        end if
    end if
    !
    !  Unless PNONC is to be computed, make sure it is legal.
    !
    if ( which /= 5 ) then
        if ( pnonc < 0.0D+00 ) then
            bound = 0.0D+00
            status = -7
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFFNC - Fatal error!'
            write ( *, '(a)' ) '  Input parameter PNONC is out of range.'
            return
        end if
    end if
    !
    ! Calculate P and Q.
    !
    if ( which == 1 ) then

        call cumfnc ( f, dfn, dfd, pnonc, p, q )
        status = 0
        !
        !  Calculate F.
        !
    else if ( which == 2 ) then

        call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        f = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, f, fx, qleft, qhi )

        do while ( status == 1 )

            call cumfnc ( f, dfn, dfd, pnonc, cum, ccum )
            fx = cum - p
            call dinvr ( status, f, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFFNC - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
                return
            else
                status = 2
                bound = inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFFNC - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
                return
            end if
        end if
        !
        !  Calculate DFN.
        !
    else if ( which == 3 ) then

        call dstinv ( 1.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        dfn = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, dfn, fx, qleft, qhi )

        do while ( status == 1 )

            call cumfnc ( f, dfn, dfd, pnonc, cum, ccum )
            fx = cum - p

            call dinvr ( status, dfn, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFFNC - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFFNC - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if
        !
        !  Calculate DFD.
        !
    else if ( which == 4 ) then

        call dstinv ( 1.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        dfd = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, dfd, fx, qleft, qhi )

        do while ( status == 1 )

            call cumfnc ( f, dfn, dfd, pnonc, cum, ccum )
            fx = cum - p
            call dinvr ( status, dfd, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFFNC - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFFNC - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if
        !
        !  Calculate PNONC.
        !
    else if ( which == 5 ) then

        call dstinv ( 0.0D+00, tent4, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        pnonc = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, pnonc, fx, qleft, qhi )

        do while ( status == 1 )

            call cumfnc ( f, dfn, dfd, pnonc, cum, ccum )
            fx = cum - p

            call dinvr ( status, pnonc, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFFNC - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = tent4
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFFNC - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if

    end if

    return
    end
    subroutine cdfgam ( which, p, q, x, shape, scale, status, bound )

    !*****************************************************************************80
    !
    !! CDFGAM evaluates the CDF of the Gamma Distribution.
    !
    !  Discussion:
    !
    !    This routine calculates any one parameter of the Gamma distribution
    !    given the others.
    !
    !    The cumulative distribution function P is calculated directly.
    !
    !    Computation of the other parameters involves a seach for a value that
    !    produces the desired value of P.  The search relies on the
    !    monotonicity of P with respect to the other parameters.
    !
    !    The gamma density is proportional to T**(SHAPE - 1) * EXP(- SCALE * T)
    !
    !  Modified:
    !
    !    14 April 2007
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 654:
    !    Computation of the incomplete gamma function ratios and their inverse,
    !    ACM Transactions on Mathematical Software,
    !    Volume 12, 1986, pages 377-393.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) WHICH, indicates which argument is to be
    !    calculated from the others.
    !    1: Calculate P and Q from X, SHAPE and SCALE;
    !    2: Calculate X from P, Q, SHAPE and SCALE;
    !    3: Calculate SHAPE from P, Q, X and SCALE;
    !    4: Calculate SCALE from P, Q, X and SHAPE.
    !
    !    Input/output, real ( kind = 8 ) P, the integral from 0 to X of the
    !    Gamma density.  If this is an input value, it should lie in the
    !    range: [0,1].
    !
    !    Input/output, real ( kind = 8 ) Q, equal to 1-P.  If Q is an input
    !    value, it should lie in the range [0,1].  If Q is an output value,
    !    it will lie in the range [0,1].
    !
    !    Input/output, real ( kind = 8 ) X, the upper limit of integration of
    !    the Gamma density.  If this is an input value, it should lie in the
    !    range: [0, +infinity).  If it is an output value, it will lie in
    !    the range: [0,1E300].
    !
    !    Input/output, real ( kind = 8 ) SHAPE, the shape parameter of the
    !    Gamma density.  If this is an input value, it should lie in the range:
    !    (0, +infinity).  If it is an output value, it will be searched for
    !    in the range: [1.0D-300,1.0D+300].
    !
    !    Input/output, real ( kind = 8 ) SCALE, the scale parameter of the
    !    Gamma density.  If this is an input value, it should lie in the range
    !    (0, +infinity).  If it is an output value, it will be searched for
    !    in the range: (1.0D-300,1.0D+300].
    !
    !    Output, integer ( kind = 4 ) STATUS, reports the status of the computation.
    !     0, if the calculation completed correctly;
    !    -I, if the input parameter number I is out of range;
    !    +1, if the answer appears to be lower than lowest search bound;
    !    +2, if the answer appears to be higher than greatest search bound;
    !    +3, if P + Q /= 1;
    !    +10, if the Gamma or inverse Gamma routine cannot compute the answer.
    !    This usually happens only for X and SHAPE very large (more than 1.0D+10.
    !
    !    Output, real ( kind = 8 ) BOUND, is only defined if STATUS is nonzero.
    !    If STATUS is negative, then this is the value exceeded by parameter I.
    !    if STATUS is 1 or 2, this is the search bound that was exceeded.
    !
    implicit none

    real ( kind = 8 ), parameter :: atol = 1.0D-10
    real ( kind = 8 ) bound
    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) fx
    integer ( kind = 4 ) ierr
    real ( kind = 8 ), parameter :: inf=1.0D+300
    real ( kind = 8 ) p
    real ( kind = 8 ) porq
    real ( kind = 8 ) q
    logical qhi
    logical qleft
    real ( kind = 8 ) scale
    real ( kind = 8 ) shape
    real ( kind = 8 ), parameter :: tol = 1.0D-08
    integer ( kind = 4 ) status,which
    real ( kind = 8 ) x
    real ( kind = 8 ) xscale
    real ( kind = 8 ) xx

    status = 0
    bound = 0.0D+00
    !
    !  Check the arguments.
    !
    if ( which < 1 ) then
        bound = 1.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFGAM - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 4.'
        return
    end if

    if ( 4 < which ) then
        bound = 4.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFGAM - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 4.'
        return
    end if
    !
    !  Unless P is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( p < 0.0D+00 ) then
            status = -2
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFGAM - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        else if ( 1.0D+00 < p ) then
            status = -2
            bound = 1.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFGAM - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        end if
    end if
    !
    !  Unless Q is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( q < 0.0D+00 ) then
            status = -3
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFGAM - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        else if ( 1.0D+00 < q ) then
            status = -3
            bound = 1.0
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFGAM - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        end if
    end if
    !
    !  Unless X is to be computed, make sure it is legal.
    !
    if ( which /= 2 ) then
        if ( x < 0.0D+00 ) then
            bound = 0.0D+00
            status = -4
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFGAM - Fatal error!'
            write ( *, '(a)' ) '  Input parameter X is out of range.'
            return
        end if
    end if
    !
    !  Unless SHAPE is to be computed, make sure it is legal.
    !
    if ( which /= 3 ) then
        if ( shape <= 0.0D+00 ) then
            bound = 0.0D+00
            status = -5
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFGAM - Fatal error!'
            write ( *, '(a)' ) '  Input parameter SHAPE is out of range.'
            return
        end if
    end if
    !
    !  Unless SCALE is to be computed, make sure it is legal.
    !
    if ( which /= 4 ) then
        if ( scale <= 0.0D+00 ) then
            bound = 0.0D+00
            status = -6
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFGAM - Fatal error!'
            write ( *, '(a)' ) '  Input parameter SCALE is out of range.'
            return
        end if
    end if
    !
    !  Check that P + Q = 1.
    !
    if ( which /= 1 ) then
        if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+0 ) ) then
            status = 3
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFGAM - Fatal error!'
            write ( *, '(a)' ) '  P + Q /= 1.'
            return
        end if
    end if
    !
    !  Select the minimum of P or Q.
    !
    if ( which /= 1 ) then
        porq = min ( p, q )
    end if
    !
    !  Calculate P and Q.
    !
    if ( which == 1 ) then

        status = 0
        xscale = x * scale
        call cumgam ( xscale, shape, p, q )

        if ( 1.5D+00 < porq ) then
            status = 10
        end if
        !
        !  Calculate X.
        !
    else if ( which == 2 ) then

        call gamma_inc_inv ( shape, xx, -1.0D+00, p, q, ierr )

        if ( ierr < 0.0D+00 ) then
            status = 10
            return
        end if

        x = xx / scale
        status = 0
        !
        !  Calculate SHAPE.
        !
    else if ( which == 3 ) then

        xscale = x * scale

        call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        shape = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, shape, fx, qleft, qhi )

        do while ( status == 1 )

            call cumgam ( xscale, shape, cum, ccum )

            if ( p <= q ) then
                fx = cum - p
            else
                fx = ccum - q
            end if

            if ( p <= q .and. 1.5D+00 < cum ) then
                status = 10
                return
            else if ( q < p .and. 1.5D+00 < ccum ) then
                status = 10
                return
            end if

            call dinvr ( status, shape, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFGAM - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFGAM - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if
        !
        !  Calculate SCALE.
        !
    else if ( which == 4 ) then

        call gamma_inc_inv ( shape, xx, -1.0D+00, p, q, ierr )

        if ( ierr < 0.0D+00 ) then
            status = 10
        else
            scale = xx / x
            status = 0
        end if

    end if

    return
    end
    subroutine cdfnbn ( which, p, q, f, s, pr, ompr, status, bound )

    !*****************************************************************************80
    !
    !! CDFNBN evaluates the CDF of the Negative Binomial distribution
    !
    !  Discussion:
    !
    !    This routine calculates any one parameter of the negative binomial
    !    distribution given values for the others.
    !
    !    The cumulative negative binomial distribution returns the
    !    probability that there will be F or fewer failures before the
    !    S-th success in binomial trials each of which has probability of
    !    success PR.
    !
    !    The individual term of the negative binomial is the probability of
    !    F failures before S successes and is
    !    Choose( F, S+F-1 ) * PR^(S) * (1-PR)^F
    !
    !    Computation of other parameters involve a seach for a value that
    !    produces the desired value of P.  The search relies on the
    !    monotonicity of P with respect to the other parameters.
    !
    !  Modified:
    !
    !    14 April 2007
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions
    !    1966, Formula 26.5.26.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) WHICH, indicates which argument is to be
    !    calculated from the others.
    !    1: Calculate P and Q from F, S, PR and OMPR;
    !    2: Calculate F from P, Q, S, PR and OMPR;
    !    3: Calculate S from P, Q, F, PR and OMPR;
    !    4: Calculate PR and OMPR from P, Q, F and S.
    !
    !    Input/output, real ( kind = 8 ) P, the cumulation from 0 to F of
    !    the negative binomial distribution.  If P is an input value, it
    !    should lie in the range [0,1].
    !
    !    Input/output, real ( kind = 8 ) Q, equal to 1-P.  If Q is an input
    !    value, it should lie in the range [0,1].  If Q is an output value,
    !    it will lie in the range [0,1].
    !
    !    Input/output, real ( kind = 8 ) F, the upper limit of cumulation of
    !    the binomial distribution.  There are F or fewer failures before
    !    the S-th success.  If this is an input value, it may lie in the
    !    range [0,+infinity), and if it is an output value, it will be searched
    !    for in the range [0,1.0D+300].
    !
    !    Input/output, real ( kind = 8 ) S, the number of successes.
    !    If this is an input value, it should lie in the range: [0, +infinity).
    !    If it is an output value, it will be searched for in the range:
    !    [0, 1.0D+300].
    !
    !    Input/output, real ( kind = 8 ) PR, the probability of success in each
    !    binomial trial.  Whether an input or output value, it should lie in the
    !    range [0,1].
    !
    !    Input/output, real ( kind = 8 ) OMPR, the value of (1-PR).  Whether an
    !    input or output value, it should lie in the range [0,1].
    !
    !    Output, integer ( kind = 4 ) STATUS, reports the status of the computation.
    !     0, if the calculation completed correctly;
    !    -I, if the input parameter number I is out of range;
    !    +1, if the answer appears to be lower than lowest search bound;
    !    +2, if the answer appears to be higher than greatest search bound;
    !    +3, if P + Q /= 1;
    !    +4, if PR + OMPR /= 1.
    !
    !    Output, real ( kind = 8 ) BOUND, is only defined if STATUS is nonzero.
    !    If STATUS is negative, then this is the value exceeded by parameter I.
    !    if STATUS is 1 or 2, this is the search bound that was exceeded.
    !
    implicit none

    real ( kind = 8 ), parameter :: atol = 1.0D-10
    real ( kind = 8 ) bound
    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) f
    real ( kind = 8 ) fx
    real ( kind = 8 ), parameter :: inf = 1.0D+300
    real ( kind = 8 ) ompr
    real ( kind = 8 ) p
    real ( kind = 8 ) pr
    real ( kind = 8 ) q
    logical qhi
    logical qleft
    real ( kind = 8 ) s
    integer ( kind = 4 ) status
    real ( kind = 8 ), parameter :: tol = 1.0D-08
    integer ( kind = 4 ) which
    real ( kind = 8 ) xhi
    real ( kind = 8 ) xlo

    status = 0
    bound = 0.0D+00
    !
    !  Check the arguments.
    !
    if ( which < 1 ) then
        bound = 1.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFNBN - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 4.'
        return
    end if

    if ( 4 < which ) then
        bound = 4.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFNBN - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 4.'
        return
    end if
    !
    !  Unless P is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( p < 0.0D+00 ) then
            status = -2
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNBN - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        else if ( 1.0D+00 < p ) then
            status = -2
            bound = 1.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNBN - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        end if
    end if
    !
    !  Unless Q is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( q < 0.0D+00 ) then
            status = -3
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNBN - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        else if ( 1.0D+00 < q ) then
            status = -3
            bound = 1.0
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNBN - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        end if
    end if
    !
    !  Unless F is to be computed, make sure it is legal.
    !
    if ( which /= 2 ) then
        if ( f < 0.0D+00 ) then
            bound = 0.0D+00
            status = -4
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNBN - Fatal error!'
            write ( *, '(a)' ) '  Input parameter F is out of range.'
            return
        end if
    end if
    !
    !  Unless S is to be computed, make sure it is legal.
    !
    if ( which /= 3 ) then
        if ( s < 0.0D+00 ) then
            bound = 0.0D+00
            status = -5
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNBN - Fatal error!'
            write ( *, '(a)' ) '  Input parameter S is out of range.'
            return
        end if
    end if
    !
    !  Unless PR is to be computed, make sure it is legal.
    !
    if ( which /= 4 ) then
        if ( pr < 0.0D+00 ) then
            bound = 0.0D+00
            status = -6
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNBN - Fatal error!'
            write ( *, '(a)' ) '  Input parameter PR is out of range.'
            return
        else if ( 1.0D+00 < pr ) then
            bound = 1.0D+00
            status = -6
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNBN - Fatal error!'
            write ( *, '(a)' ) '  Input parameter PR is out of range.'
            return
        end if
    end if
    !
    !  Unless OMPR is to be computed, make sure it is legal.
    !
    if ( which /= 4 ) then
        if ( ompr < 0.0D+00 ) then
            bound = 0.0D+00
            status = -7
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNBN - Fatal error!'
            write ( *, '(a)' ) '  Input parameter OMPR is out of range.'
            return
        else if ( 1.0D+00 < ompr ) then
            bound = 1.0D+00
            status = -7
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNBN - Fatal error!'
            write ( *, '(a)' ) '  Input parameter OMPR is out of range.'
            return
        end if
    end if
    !
    !  Check that P + Q = 1.
    !
    if ( which /= 1 ) then
        if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then
            status = 3
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNBN - Fatal error!'
            write ( *, '(a)' ) '  P + Q /= 1.'
            return
        end if
    end if
    !
    !  Check that PR + OMPR = 1.
    !
    if ( which /= 4 ) then
        if ( 3.0D+00 * epsilon ( pr ) < abs ( ( pr + ompr ) - 1.0D+00 ) ) then
            status = 4
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNBN - Fatal error!'
            write ( *, '(a)' ) '  PR + OMPR /= 1.'
            return
        end if
    end if
    !
    !  Calculate P and Q.
    !
    if ( which == 1 ) then

        call cumnbn ( f, s, pr, ompr, p, q )
        status = 0
        !
        !  Calculate F.
        !
    else if ( which == 2 ) then

        call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        f = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, f, fx, qleft, qhi )

        do while ( status == 1 )

            call cumnbn ( f, s, pr, ompr, cum, ccum )

            if ( p <= q ) then
                fx = cum - p
            else
                fx = ccum - q
            end if

            call dinvr ( status, f, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFNBN - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFNBN - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if
        !
        !  Calculate S.
        !
    else if ( which == 3 ) then

        call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        s = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, s, fx, qleft, qhi )

        do while ( status == 1 )

            call cumnbn ( f, s, pr, ompr, cum, ccum )

            if ( p <= q ) then
                fx = cum - p
            else
                fx = ccum - q
            end if

            call dinvr ( status, s, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFNBN - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFNBn - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if
        !
        !  Calculate PR and OMPR.
        !
    else if ( which == 4 ) then

        call dstzr ( 0.0D+00, 1.0D+00, atol, tol )

        if ( p <= q ) then

            status = 0
            call dzror ( status, pr, fx, xlo, xhi, qleft, qhi )
            ompr = 1.0D+00 - pr

            do while ( status == 1 )

                call cumnbn ( f, s, pr, ompr, cum, ccum )
                fx = cum - p
                call dzror ( status, pr, fx, xlo, xhi, qleft, qhi )
                ompr = 1.0D+00 - pr

            end do

        else

            status = 0
            call dzror ( status, ompr, fx, xlo, xhi, qleft, qhi )
            pr = 1.0D+00 - ompr

            do while ( status == 1 )

                call cumnbn ( f, s, pr, ompr, cum, ccum )
                fx = ccum - q
                call dzror ( status, ompr, fx, xlo, xhi, qleft, qhi )
                pr = 1.0D+00 - ompr

            end do

        end if

        if ( status == -1 ) then

            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFNBN - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = 1.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFNBN - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if

        end if

    end if

    return
    end

    subroutine cdfnor ( which, p, q, x, mean, sd, status, bound )

    !*****************************************************************************80
    !
    !! CDFNOR evaluates the CDF of the Normal distribution.
    !
    !  Discussion:
    !
    !    A slightly modified version of ANORM from SPECFUN
    !    is used to calculate the cumulative standard normal distribution.
    !
    !    The rational functions from pages 90-95 of Kennedy and Gentle
    !    are used as starting values to a Newton iteration which
    !    compute the inverse standard normal.  Therefore no searches are
    !    necessary for any parameter.
    !
    !    For X < -15, the asymptotic expansion for the normal is used  as
    !    the starting value in finding the inverse standard normal.
    !
    !    The normal density is proportional to
    !    exp ( - 0.5D+00 * (( X - MEAN)/SD)**2)
    !
    !  Modified:
    !
    !    14 April 2007
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions
    !    1966, Formula 26.2.12.
    !
    !    William Cody,
    !    Algorithm 715:
    !    SPECFUN - A Portable FORTRAN Package of
    !    Special Function Routines and Test Drivers,
    !    ACM Transactions on Mathematical Software,
    !    Volume 19, Number 1, pages 22-32, 1993.
    !
    !    William Kennedy, James Gentle,
    !    Statistical Computing,
    !    Marcel Dekker, NY, 1980,
    !    QA276.4 K46
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) WHICH, indicates which argument is to be
    !    calculated from the others.
    !    1: Calculate P and Q from X, MEAN and SD;
    !    2: Calculate X from P, Q, MEAN and SD;
    !    3: Calculate MEAN from P, Q, X and SD;
    !    4: Calculate SD from P, Q, X and MEAN.
    !
    !    Input/output, real ( kind = 8 ) P, the integral from -infinity to X
    !    of the Normal density.  If this is an input or output value, it will
    !    lie in the range [0,1].
    !
    !    Input/output, real ( kind = 8 ) Q, equal to 1-P.  If Q is an input
    !    value, it should lie in the range [0,1].  If Q is an output value,
    !    it will lie in the range [0,1].
    !
    !    Input/output, real ( kind = 8 ) X, the upper limit of integration of
    !    the Normal density.
    !
    !    Input/output, real ( kind = 8 ) MEAN, the mean of the Normal density.
    !
    !    Input/output, real ( kind = 8 ) SD, the standard deviation of the
    !    Normal density.  If this is an input value, it should lie in the
    !    range (0,+infinity).
    !
    !    Output, integer ( kind = 4 ) STATUS, the status of the calculation.
    !    0, if calculation completed correctly;
    !    -I, if input parameter number I is out of range;
    !    1, if answer appears to be lower than lowest search bound;
    !    2, if answer appears to be higher than greatest search bound;
    !    3, if P + Q /= 1.
    !
    !    Output, real ( kind = 8 ) BOUND, is only defined if STATUS is nonzero.
    !    If STATUS is negative, then this is the value exceeded by parameter I.
    !    if STATUS is 1 or 2, this is the search bound that was exceeded.
    !
    implicit none

    real ( kind = 8 ) bound
    real ( kind = 8 ) dinvnr
    real ( kind = 8 ) mean
    real ( kind = 8 ) p
    real ( kind = 8 ) q
    real ( kind = 8 ) sd
    integer ( kind = 4 ) status
    integer ( kind = 4 ) which
    real ( kind = 8 ) x
    real ( kind = 8 ) z

    status = 0
    bound = 0.0D+00
    !
    !  Check the arguments.
    !
    status = 0

    if ( which < 1 ) then
        status = -1
        bound = 1.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFNOR - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 4.'
        return
    else if ( 4 < which ) then
        status = -1
        bound = 4.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFNOR - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 4.'
        return
    end if
    !
    !  Unless P is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( p < 0.0D+00 ) then
            status = -2
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNOR - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        else if ( 1.0D+00 < p ) then
            status = -2
            bound = 1.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNOR - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        end if
    end if
    !
    !  Unless Q is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( q < 0.0D+00 ) then
            status = -3
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNOR - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        else if ( 1.0D+00 < q ) then
            status = -3
            bound = 1.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNOR - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        end if
    end if
    !
    !  Check that P + Q = 1.
    !
    if ( which /= 1 ) then
        if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then
            status = 3
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNOR - Fatal error!'
            write ( *, '(a)' ) '  P + Q /= 1.'
            return
        end if
    end if

    if ( which /= 4 ) then
        if ( sd <= 0.0D+00 ) then
            bound = 0.0D+00
            status = -6
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFNOR - Fatal error!'
            write ( *, '(a)' ) '  Input parameter SD is out of range.'
            return
        end if
    end if
    !
    !  Calculate P and Q.
    !
    if ( which == 1 ) then

        z = ( x - mean ) / sd
        call cumnor ( z, p, q )
        !
        !  Calculate X.
        !
    else if ( which == 2 ) then

        z = dinvnr ( p, q )
        x = sd * z + mean
        !
        !  Calculate MEAN.
        !
    else if ( which == 3 ) then

        z = dinvnr ( p, q )
        mean = x - sd * z
        !
        !  Calculate SD.
        !
    else if ( which == 4 ) then

        z = dinvnr ( p, q )
        sd = ( x - mean ) / z

    end if

    return
    end
    subroutine cdfpoi ( which, p, q, s, xlam, status, bound )

    !*****************************************************************************80
    !
    !! CDFPOI evaluates the CDF of the Poisson distribution.
    !
    !  Discussion:
    !
    !    This routine calculates any one parameter of the Poisson distribution
    !    given the others.
    !
    !    The value P of the cumulative distribution function is calculated
    !    directly.
    !
    !    Computation of other parameters involve a seach for a value that
    !    produces the desired value of P.  The search relies on the
    !    monotonicity of P with respect to the other parameters.
    !
    !  Modified:
    !
    !    14 April 2007
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions
    !    1966, Formula 26.4.21.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) WHICH, indicates which argument is to be
    !    calculated from the others.
    !    1: Calculate P and Q from S and XLAM;
    !    2: Calculate A from P, Q and XLAM;
    !    3: Calculate XLAM from P, Q and S.
    !
    !    Input/output, real ( kind = 8 ) P, the cumulation from 0 to S of the
    !    Poisson density.  Whether this is an input or output value, it will
    !    lie in the range [0,1].
    !
    !    Input/output, real ( kind = 8 ) Q, equal to 1-P.  If Q is an input
    !    value, it should lie in the range [0,1].  If Q is an output value,
    !    it will lie in the range [0,1].
    !
    !    Input/output, real ( kind = 8 ) S, the upper limit of cumulation of
    !    the Poisson CDF.  If this is an input value, it should lie in
    !    the range: [0, +infinity).  If it is an output value, it will be
    !    searched for in the range: [0,1.0D+300].
    !
    !    Input/output, real ( kind = 8 ) XLAM, the mean of the Poisson
    !    distribution.  If this is an input value, it should lie in the range
    !    [0, +infinity).  If it is an output value, it will be searched for
    !    in the range: [0,1E300].
    !
    !    Output, integer ( kind = 4 ) STATUS, reports the status of the computation.
    !     0, if the calculation completed correctly;
    !    -I, if the input parameter number I is out of range;
    !    +1, if the answer appears to be lower than lowest search bound;
    !    +2, if the answer appears to be higher than greatest search bound;
    !    +3, if P + Q /= 1.
    !
    !    Output, real ( kind = 8 ) BOUND, is only defined if STATUS is nonzero.
    !    If STATUS is negative, then this is the value exceeded by parameter I.
    !    if STATUS is 1 or 2, this is the search bound that was exceeded.
    !
    implicit none

    real ( kind = 8 ), parameter :: atol = 1.0D-10
    real ( kind = 8 ) bound
    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) fx
    real ( kind = 8 ), parameter :: inf = 1.0D+300
    real ( kind = 8 ) p
    real ( kind = 8 ) q
    logical qhi
    logical qleft
    real ( kind = 8 ) s
    integer ( kind = 4 ) status
    real ( kind = 8 ), parameter :: tol = 1.0D-08
    integer ( kind = 4 ) which
    real ( kind = 8 ) xlam

    status = 0
    bound = 0.0D+00
    !
    !  Check the arguments.
    !
    if ( which < 1 ) then
        bound = 1.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFPOI - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 3.'
        return
    end if

    if ( 3 < which ) then
        bound = 3.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFPOI - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 3.'
        return
    end if
    !
    !  Unless P is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( p < 0.0D+00 ) then
            status = -2
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFPOI - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        else if ( 1.0D+00 < p ) then
            status = -2
            bound = 1.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFPOI - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        end if
    end if
    !
    !  Unless Q is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( q < 0.0D+00 ) then
            status = -3
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFPOI - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        else if ( 1.0D+00 < q ) then
            status = -3
            bound = 1.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFPOI - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        end if
    end if
    !
    !  Unless S is to be computed, make sure it is legal.
    !
    if ( which /= 2 ) then
        if ( s < 0.0D+00 ) then
            bound = 0.0D+00
            status = -4
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFPOI - Fatal error!'
            write ( *, '(a)' ) '  Input parameter S is out of range.'
            return
        end if
    end if
    !
    !  Unless XLAM is to be computed, make sure it is legal.
    !
    if ( which /= 3 ) then
        if ( xlam < 0.0D+00 ) then
            bound = 0.0D+00
            status = -5
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFPOI - Fatal error!'
            write ( *, '(a)' ) '  Input parameter XLAM is out of range.'
            return
        end if
    end if
    !
    !  Check that P + Q = 1.
    !
    if ( which /= 1 ) then
        if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then
            status = 3
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFPOI - Fatal error!'
            write ( *, '(a)' ) '  P + Q /= 1.'
            return
        end if
    end if
    !
    !  Calculate P and Q.
    !
    if ( which == 1 ) then

        call cumpoi ( s, xlam, p, q )
        status = 0
        !
        !  Calculate S.
        !
    else if ( which == 2 ) then

        call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        s = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, s, fx, qleft, qhi )

        do while ( status == 1 )

            call cumpoi ( s, xlam, cum, ccum )

            if ( p <= q ) then
                fx = cum - p
            else
                fx = ccum - q
            end if

            call dinvr ( status, s, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFPOI - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFPOI - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if
        !
        !  Calculate XLAM.
        !
    else if ( which == 3 ) then

        call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        xlam = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, xlam, fx, qleft, qhi )

        do while ( status == 1 )

            call cumpoi ( s, xlam, cum, ccum )

            if ( p <= q ) then
                fx = cum - p
            else
                fx = ccum - q
            end if

            call dinvr ( status, xlam, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFPOI - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFPOI - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if

    end if

    return
    end
    subroutine cdft ( which, p, q, t, df, status, bound )

    !*****************************************************************************80
    !
    !! CDFT evaluates the CDF of the T distribution.
    !
    !  Discussion:
    !
    !    This routine calculates any one parameter of the T distribution
    !    given the others.
    !
    !    The value P of the cumulative distribution function is calculated
    !    directly.
    !
    !    Computation of other parameters involve a seach for a value that
    !    produces the desired value of P.   The search relies on the
    !    monotonicity of P with respect to the other parameters.
    !
    !    The original version of this routine allowed the search interval
    !    to extend from -1.0D+300 to +1.0D+300, which is fine until you
    !    try to evaluate a function at such a point!
    !
    !  Modified:
    !
    !    14 April 2007
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions
    !    1966, Formula 26.5.27.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) WHICH, indicates which argument is to be
    !    calculated from the others.
    !    1 : Calculate P and Q from T and DF;
    !    2 : Calculate T from P, Q and DF;
    !    3 : Calculate DF from P, Q and T.
    !
    !    Input/output, real ( kind = 8 ) P, the integral from -infinity to T of
    !    the T-density.  Whether an input or output value, this will lie in the
    !    range [0,1].
    !
    !    Input/output, real ( kind = 8 ) Q, equal to 1-P.  If Q is an input
    !    value, it should lie in the range [0,1].  If Q is an output value,
    !    it will lie in the range [0,1].
    !
    !    Input/output, real ( kind = 8 ) T, the upper limit of integration of
    !    the T-density.  If this is an input value, it may have any value.
    !    It it is an output value, it will be searched for in the range
    !    [ -1.0D+30, 1.0D+30 ].
    !
    !    Input/output, real ( kind = 8 ) DF, the number of degrees of freedom
    !    of the T distribution.  If this is an input value, it should lie
    !    in the range: (0 , +infinity).  If it is an output value, it will be
    !    searched for in the range: [1, 1.0D+10].
    !
    !    Output, integer ( kind = 4 ) STATUS, reports the status of the computation.
    !     0, if the calculation completed correctly;
    !    -I, if the input parameter number I is out of range;
    !    +1, if the answer appears to be lower than lowest search bound;
    !    +2, if the answer appears to be higher than greatest search bound;
    !    +3, if P + Q /= 1.
    !
    !    Output, real ( kind = 8 ) BOUND, is only defined if STATUS is nonzero.
    !    If STATUS is negative, then this is the value exceeded by parameter I.
    !    if STATUS is 1 or 2, this is the search bound that was exceeded.
    !
    implicit none

    real ( kind = 8 ), parameter :: atol = 1.0D-10
    real ( kind = 8 ) bound
    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) df
    real ( kind = 8 ) dt1
    real ( kind = 8 ) fx
    real ( kind = 8 ), parameter :: inf = 1.0D+30
    real ( kind = 8 ), parameter :: maxdf = 1.0D+10
    real ( kind = 8 ) p
    real ( kind = 8 ) q
    logical qhi
    logical qleft
    integer ( kind = 4 ) status
    real ( kind = 8 ) t
    real ( kind = 8 ), parameter :: tol = 1.0D-08
    integer ( kind = 4 ) which

    status = 0
    bound = 0.0D+00
    !
    !  Check the arguments.
    !
    if ( which < 1 ) then
        bound = 1.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFT - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 3.'
        return
    end if

    if ( 3 < which ) then
        bound = 3.0D+00
        status = -1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFT - Fatal error!'
        write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
        write ( *, '(a)' ) '  Legal values are between 1 and 3.'
        return
    end if
    !
    !  Unless P is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( p < 0.0D+00 ) then
            status = -2
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFT - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        else if ( 1.0D+00 < p ) then
            status = -2
            bound = 1.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFT - Fatal error!'
            write ( *, '(a)' ) '  Input parameter P is out of range.'
            return
        end if
    end if
    !
    !  Unless Q is to be computed, make sure it is legal.
    !
    if ( which /= 1 ) then
        if ( q < 0.0D+00 ) then
            status = -3
            bound = 0.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFT - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        else if ( 1.0D+00 < q ) then
            status = -3
            bound = 1.0D+00
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFT - Fatal error!'
            write ( *, '(a)' ) '  Input parameter Q is out of range.'
            return
        end if
    end if
    !
    !  Unless DF is to be computed, make sure it is legal.
    !
    if ( which /= 3 ) then
        if ( df <= 0.0D+00 ) then
            bound = 0.0D+00
            status = -5
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFT - Fatal error!'
            write ( *, '(a)' ) '  Input parameter DF is out of range.'
            return
        end if
    end if
    !
    !  Check that P + Q = 1.
    !
    if ( which /= 1 ) then
        if ( 3.0D+00 * epsilon ( 1.0D+00 ) &
            < abs ( ( p + q ) - 1.0D+00 ) ) then
            status = 3
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'CDFT - Fatal error!'
            write ( *, '(a)' ) '  P + Q /= 1.'
            return
        end if
    end if
    !
    !  Calculate P and Q.
    !
    if ( which == 1 ) then

        call cumt ( t, df, p, q )
        status = 0
        !
        !  Calculate T.
        !
    else if ( which == 2 ) then

        call dstinv ( -inf, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        t = dt1 ( p, q, df )
        fx = 0.0D+00

        call dinvr ( status, t, fx, qleft, qhi )

        do while ( status == 1 )

            call cumt ( t, df, cum, ccum )

            if ( p <= q ) then
                fx = cum - p
            else
                fx = ccum - q
            end if

            call dinvr ( status, t, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft )then
                status = 1
                bound = -inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFT - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = inf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFT - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if
        !
        !  Calculate DF.
        !
    else if ( which == 3 ) then

        call dstinv ( 1.0D+00, maxdf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

        status = 0
        df = 5.0D+00
        fx = 0.0D+00

        call dinvr ( status, df, fx, qleft, qhi )

        do while ( status == 1 )

            call cumt ( t, df, cum, ccum )

            if ( p <= q ) then
                fx = cum - p
            else
                fx = ccum - q
            end if

            call dinvr ( status, df, fx, qleft, qhi )

        end do

        if ( status == -1 ) then
            if ( qleft ) then
                status = 1
                bound = 0.0D+00
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFT - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be lower than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            else
                status = 2
                bound = maxdf
                write ( *, '(a)' ) ' '
                write ( *, '(a)' ) 'CDFT - Warning!'
                write ( *, '(a)' ) '  The desired answer appears to be higher than'
                write ( *, '(a,g14.6)' ) '  the search bound of ', bound
            end if
        end if

    end if

    return
    end
    subroutine chi_noncentral_cdf_values ( n_data, x, lambda, df, cdf )

    !*****************************************************************************80
    !
    !! CHI_NONCENTRAL_CDF_VALUES returns values of the noncentral chi CDF.
    !
    !  Discussion:
    !
    !    The CDF of the noncentral chi square distribution can be evaluated
    !    within Mathematica by commands such as:
    !
    !      Needs["Statistics`ContinuousDistributions`"]
    !      CDF [ NoncentralChiSquareDistribution [ DF, LAMBDA ], X ]
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    12 June 2004
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Stephen Wolfram,
    !    The Mathematica Book,
    !    Fourth Edition,
    !    Wolfram Media / Cambridge University Press, 1999.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) N_DATA.  The user sets N_DATA to 0
    !    before the first call.  On each call, the routine increments N_DATA by 1,
    !    and returns the corresponding data; when there is no more data, the
    !    output value of N_DATA will be 0 again.
    !
    !    Output, real ( kind = 8 ) X, the argument of the function.
    !
    !    Output, real ( kind = 8 ) LAMBDA, the noncentrality parameter.
    !
    !    Output, integer ( kind = 4 ) DF, the number of degrees of freedom.
    !
    !    Output, real ( kind = 8 ) CDF, the noncentral chi CDF.
    !
    implicit none

    integer ( kind = 4 ), parameter :: n_max = 27

    real ( kind = 8 ) cdf
    real, save, dimension ( n_max ) :: cdf_vec = (/ &
        0.839944D+00, 0.695906D+00, 0.535088D+00, &
        0.764784D+00, 0.620644D+00, 0.469167D+00, &
        0.307088D+00, 0.220382D+00, 0.150025D+00, &
        0.307116D-02, 0.176398D-02, 0.981679D-03, &
        0.165175D-01, 0.202342D-03, 0.498448D-06, &
        0.151325D-01, 0.209041D-02, 0.246502D-03, &
        0.263684D-01, 0.185798D-01, 0.130574D-01, &
        0.583804D-01, 0.424978D-01, 0.308214D-01, &
        0.105788D+00, 0.794084D-01, 0.593201D-01 /)
    integer ( kind = 4 ) df
    integer ( kind = 4 ), save, dimension ( n_max ) :: df_vec = (/ &
        1,   2,   3, &
        1,   2,   3, &
        1,   2,   3, &
        1,   2,   3, &
        60,  80, 100, &
        1,   2,   3, &
        10,  10,  10, &
        10,  10,  10, &
        10,  10,  10 /)
    real ( kind = 8 ) lambda
    real, save, dimension ( n_max ) :: lambda_vec = (/ &
        0.5D+00,  0.5D+00,  0.5D+00, &
        1.0D+00,  1.0D+00,  1.0D+00, &
        5.0D+00,  5.0D+00,  5.0D+00, &
        20.0D+00, 20.0D+00, 20.0D+00, &
        30.0D+00, 30.0D+00, 30.0D+00, &
        5.0D+00,  5.0D+00,  5.0D+00, &
        2.0D+00,  3.0D+00,  4.0D+00, &
        2.0D+00,  3.0D+00,  4.0D+00, &
        2.0D+00,  3.0D+00,  4.0D+00 /)
    integer ( kind = 4 ) n_data
    real ( kind = 8 ) x
    real, save, dimension ( n_max ) :: x_vec = (/ &
        3.000D+00,  3.000D+00,  3.000D+00, &
        3.000D+00,  3.000D+00,  3.000D+00, &
        3.000D+00,  3.000D+00,  3.000D+00, &
        3.000D+00,  3.000D+00,  3.000D+00, &
        60.000D+00, 60.000D+00, 60.000D+00, &
        0.050D+00,  0.050D+00,  0.050D+00, &
        4.000D+00,  4.000D+00,  4.000D+00, &
        5.000D+00,  5.000D+00,  5.000D+00, &
        6.000D+00,  6.000D+00,  6.000D+00 /)

    if ( n_data < 0 ) then
        n_data = 0
    end if

    n_data = n_data + 1

    if ( n_max < n_data ) then
        n_data = 0
        x = 0.0D+00
        lambda = 0.0D+00
        df = 0
        cdf = 0.0D+00
    else
        x = x_vec(n_data)
        lambda = lambda_vec(n_data)
        df = df_vec(n_data)
        cdf = cdf_vec(n_data)
    end if

    return
    end
    subroutine chi_square_cdf_values ( n_data, a, x, fx )

    !*****************************************************************************80
    !
    !! CHI_SQUARE_CDF_VALUES returns some values of the Chi-Square CDF.
    !
    !  Discussion:
    !
    !    The value of CHI_CDF ( DF, X ) can be evaluated in Mathematica by
    !    commands like:
    !
    !      Needs["Statistics`ContinuousDistributions`"]
    !      CDF[ChiSquareDistribution[DF], X ]
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    11 June 2004
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions,
    !    US Department of Commerce, 1964.
    !
    !    Stephen Wolfram,
    !    The Mathematica Book,
    !    Fourth Edition,
    !    Wolfram Media / Cambridge University Press, 1999.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) N_DATA.  The user sets N_DATA to 0
    !    before the first call.  On each call, the routine increments N_DATA by 1,
    !    and returns the corresponding data; when there is no more data, the
    !    output value of N_DATA will be 0 again.
    !
    !    Output, integer ( kind = 4 ) A, real ( kind = 8 ) X, the arguments of
    !    the function.
    !
    !    Output, real ( kind = 8 ) FX, the value of the function.
    !
    implicit none

    integer ( kind = 4 ), parameter :: n_max = 21

    integer ( kind = 4 ) a
    integer ( kind = 4 ), save, dimension ( n_max ) :: a_vec = (/ &
        1,  2,  1,  2, &
        1,  2,  3,  4, &
        1,  2,  3,  4, &
        5,  3,  3,  3, &
        3,  3, 10, 10, &
        10 /)
    real ( kind = 8 ) fx
    real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ &
        0.0796557D+00, 0.00498752D+00, 0.112463D+00,    0.00995017D+00, &
        0.472911D+00,  0.181269D+00,   0.0597575D+00,   0.0175231D+00, &
        0.682689D+00,  0.393469D+00,   0.198748D+00,    0.090204D+00, &
        0.0374342D+00, 0.427593D+00,   0.608375D+00,    0.738536D+00, &
        0.828203D+00,  0.88839D+00,    0.000172116D+00, 0.00365985D+00, &
        0.0185759D+00 /)
    integer ( kind = 4 ) n_data
    real ( kind = 8 ) x
    real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ &
        0.01D+00, 0.01D+00, 0.02D+00, 0.02D+00, &
        0.40D+00, 0.40D+00, 0.40D+00, 0.40D+00, &
        1.00D+00, 1.00D+00, 1.00D+00, 1.00D+00, &
        1.00D+00, 2.00D+00, 3.00D+00, 4.00D+00, &
        5.00D+00, 6.00D+00, 1.00D+00, 2.00D+00, &
        3.00D+00 /)

    if ( n_data < 0 ) then
        n_data = 0
    end if

    n_data = n_data + 1

    if ( n_max < n_data ) then
        n_data = 0
        a = 0
        x = 0.0D+00
        fx = 0.0D+00
    else
        a = a_vec(n_data)
        x = x_vec(n_data)
        fx = fx_vec(n_data)
    end if

    return
    end
    subroutine cumbet ( x, y, a, b, cum, ccum )

    !*****************************************************************************80
    !
    !! CUMBET evaluates the cumulative incomplete beta distribution.
    !
    !  Discussion:
    !
    !    This routine calculates the CDF to X of the incomplete beta distribution
    !    with parameters A and B.  This is the integral from 0 to x
    !    of (1/B(a,b))*f(t)) where f(t) = t**(a-1) * (1-t)**(b-1)
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) X, the upper limit of integration.
    !
    !    Input, real ( kind = 8 ) Y, the value of 1-X.
    !
    !    Input, real ( kind = 8 ) A, B, the parameters of the distribution.
    !
    !    Output, real ( kind = 8 ) CUM, CCUM, the values of the cumulative
    !    density function and complementary cumulative density function.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) b
    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    integer ( kind = 4 ) ierr
    real ( kind = 8 ) x
    real ( kind = 8 ) y

    if ( x <= 0.0D+00 ) then

        cum = 0.0
        ccum = 1.0D+00

    else if ( y <= 0.0D+00 ) then

        cum = 1.0D+00
        ccum = 0.0

    else

        call beta_inc ( a, b, x, y, cum, ccum, ierr )

    end if

    return
    end
    subroutine cumbin ( s, xn, pr, ompr, cum, ccum )

    !*****************************************************************************80
    !
    !! CUMBIN evaluates the cumulative binomial distribution.
    !
    !  Discussion:
    !
    !    This routine returns the probability of 0 to S successes in XN binomial
    !    trials, each of which has a probability of success, PR.
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions
    !    1966, Formula 26.5.24.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) S, the upper limit of summation.
    !
    !    Input, real ( kind = 8 ) XN, the number of trials.
    !
    !    Input, real ( kind = 8 ) PR, the probability of success in one trial.
    !
    !    Input, real ( kind = 8 ) OMPR, equals ( 1 - PR ).
    !
    !    Output, real ( kind = 8 ) CUM, the cumulative binomial distribution.
    !
    !    Output, real ( kind = 8 ) CCUM, the complement of the cumulative
    !    binomial distribution.
    !
    implicit none

    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) ompr
    real ( kind = 8 ) pr
    real ( kind = 8 ) s
    real ( kind = 8 ) xn

    if ( s < xn ) then

        call cumbet ( pr, ompr, s + 1.0D+00, xn - s, ccum, cum )

    else

        cum = 1.0D+00
        ccum = 0.0D+00

    end if

    return
    end
    subroutine cumchi ( x, df, cum, ccum )

    !*****************************************************************************80
    !
    !! CUMCHI evaluates the cumulative chi-square distribution.
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) X, the upper limit of integration.
    !
    !    Input, real ( kind = 8 ) DF, the degrees of freedom of the
    !    chi-square distribution.
    !
    !    Output, real ( kind = 8 ) CUM, the cumulative chi-square distribution.
    !
    !    Output, real ( kind = 8 ) CCUM, the complement of the cumulative
    !    chi-square distribution.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) df
    real ( kind = 8 ) x
    real ( kind = 8 ) xx

    a = df * 0.5D+00
    xx = x * 0.5D+00

    call cumgam ( xx, a, cum, ccum )

    return
    end
    subroutine cumchn ( x, df, pnonc, cum, ccum )

    !*****************************************************************************80
    !
    !! CUMCHN evaluates the cumulative noncentral chi-square distribution.
    !
    !  Discussion:
    !
    !    This routine calculates the cumulative noncentral chi-square
    !    distribution, i.e., the probability that a random variable
    !    which follows the noncentral chi-square distribution, with
    !    noncentrality parameter PNONC and continuous degrees of
    !    freedom DF, is less than or equal to X.
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions
    !    1966, Formula 26.4.25.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) X, the upper limit of integration.
    !
    !    Input, real ( kind = 8 ) DF, the number of degrees of freedom.
    !
    !    Input, real ( kind = 8 ) PNONC, the noncentrality parameter of
    !    the noncentral chi-square distribution.
    !
    !    Output, real ( kind = 8 ) CUM, CCUM, the CDF and complementary
    !    CDF of the noncentral chi-square distribution.
    !
    !  Local Parameters:
    !
    !    Local, real ( kind = 8 ) EPS, the convergence criterion.  The sum
    !    stops when a term is less than EPS * SUM.
    !
    !    Local, integer NTIRED, the maximum number of terms to be evaluated
    !    in each sum.
    !
    !    Local, logical QCONV, is TRUE if convergence was achieved, that is,
    !    the program did not stop on NTIRED criterion.
    !
    implicit none

    real ( kind = 8 ) adj
    real ( kind = 8 ) ccum
    real ( kind = 8 ) centaj
    real ( kind = 8 ) centwt
    real ( kind = 8 ) chid2
    real ( kind = 8 ) cum
    real ( kind = 8 ) df
    real ( kind = 8 ) dfd2
    real ( kind = 8 ) dg
    real ( kind = 8 ), parameter :: eps = 0.00001D+00
    real ( kind = 8 ) gamma_log
    integer ( kind = 4 ) i
    integer ( kind = 4 ) icent
    integer ( kind = 4 ) iterb
    integer ( kind = 4 ) iterf
    real ( kind = 8 ) lcntaj
    real ( kind = 8 ) lcntwt
    real ( kind = 8 ) lfact
    integer ( kind = 4 ), parameter :: ntired = 1000
    real ( kind = 8 ) pcent
    real ( kind = 8 ) pnonc
    real ( kind = 8 ) pterm
    logical qsmall
    real ( kind = 8 ) sum1
    real ( kind = 8 ) sumadj
    real ( kind = 8 ) term
    real ( kind = 8 ) wt
    real ( kind = 8 ) x
    real ( kind = 8 ) xnonc
    real ( kind = 8 ) xx

    qsmall ( xx ) = sum1 < 1.0D-20 .or. xx < eps * sum1
    dg(i) = df +  2.0D+00  * real ( i, kind = 8 )

    if ( x <= 0.0D+00 ) then
        cum = 0.0D+00
        ccum = 1.0D+00
        return
    end if
    !
    !  When the noncentrality parameter is (essentially) zero,
    !  use cumulative chi-square distribution
    !
    if ( pnonc <= 1.0D-10 ) then
        call cumchi ( x, df, cum, ccum )
        return
    end if

    xnonc = pnonc /  2.0D+00
    !
    !  The following code calculates the weight, chi-square, and
    !  adjustment term for the central term in the infinite series.
    !  The central term is the one in which the poisson weight is
    !  greatest.  The adjustment term is the amount that must
    !  be subtracted from the chi-square to move up two degrees
    !  of freedom.
    !
    icent = int ( xnonc )
    if ( icent == 0 ) then
        icent = 1
    end if

    chid2 = x /  2.0D+00
    !
    !  Calculate central weight term.
    !
    lfact = gamma_log ( real ( icent + 1, kind = 8 ) )
    lcntwt = - xnonc + icent * log ( xnonc ) - lfact
    centwt = exp ( lcntwt )
    !
    !  Calculate central chi-square.
    !
    call cumchi ( x, dg(icent), pcent, ccum )
    !
    !  Calculate central adjustment term.
    !
    dfd2 = dg(icent) /  2.0D+00
    lfact = gamma_log ( 1.0D+00 + dfd2 )
    lcntaj = dfd2 * log ( chid2 ) - chid2 - lfact
    centaj = exp ( lcntaj )
    sum1 = centwt * pcent
    !
    !  Sum backwards from the central term towards zero.
    !  Quit whenever either
    !  (1) the zero term is reached, or
    !  (2) the term gets small relative to the sum, or
    !  (3) More than NTIRED terms are totaled.
    !
    iterb = 0
    sumadj = 0.0D+00
    adj = centaj
    wt = centwt
    i = icent
    term = 0.0D+00

    do

        dfd2 = dg(i) /  2.0D+00
        !
        !  Adjust chi-square for two fewer degrees of freedom.
        !  The adjusted value ends up in PTERM.
        !
        adj = adj * dfd2 / chid2
        sumadj = sumadj + adj
        pterm = pcent + sumadj
        !
        !  Adjust Poisson weight for J decreased by one.
        !
        wt = wt * ( i / xnonc )
        term = wt * pterm
        sum1 = sum1 + term
        i = i - 1
        iterb = iterb + 1

        if ( ntired < iterb .or. qsmall ( term ) .or. i == 0 ) then
            exit
        end if

    end do

    iterf = 0
    !
    !  Now sum forward from the central term towards infinity.
    !  Quit when either
    !    (1) the term gets small relative to the sum, or
    !    (2) More than NTIRED terms are totaled.
    !
    sumadj = centaj
    adj = centaj
    wt = centwt
    i = icent
    !
    !  Update weights for next higher J.
    !
    do

        wt = wt * ( xnonc / ( i + 1 ) )
        !
        !  Calculate PTERM and add term to sum.
        !
        pterm = pcent - sumadj
        term = wt * pterm
        sum1 = sum1 + term
        !
        !  Update adjustment term for DF for next iteration.
        !
        i = i + 1
        dfd2 = dg(i) /  2.0D+00
        adj = adj * chid2 / dfd2
        sumadj = sumadj + adj
        iterf = iterf + 1

        if ( ntired < iterf .or. qsmall ( term ) ) then
            exit
        end if

    end do

    cum = sum1
    ccum = 0.5D+00 + ( 0.5D+00 - cum )

    return
    end
    subroutine cumf ( f, dfn, dfd, cum, ccum )

    !*****************************************************************************80
    !
    !! CUMF evaluates the cumulative F distribution.
    !
    !  Discussion:
    !
    !    This routine computes the integral from 0 to F of the F density with DFN
    !    numerator and DFD denominator degrees of freedom.
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions
    !    1966, Formula 26.5.28.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) F, the upper limit of integration.
    !
    !    Input, real ( kind = 8 ) DFN, DFD, the number of degrees of
    !    freedom for the numerator and denominator.
    !
    !    Output, real ( kind = 8 ) CUM, CCUM, the value of the F CDF and
    !    the complementary F CDF.
    !
    implicit none

    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) dfd
    real ( kind = 8 ) dfn
    real ( kind = 8 ) dsum
    real ( kind = 8 ) f
    integer ( kind = 4 ) ierr
    real ( kind = 8 ) prod
    real ( kind = 8 ) xx
    real ( kind = 8 ) yy

    if ( f <= 0.0D+00 ) then
        cum = 0.0D+00
        ccum = 1.0D+00
        return
    end if

    prod = dfn * f
    !
    !  XX is such that the incomplete beta with parameters
    !  DFD/2 and DFN/2 evaluated at XX is 1 - CUM or CCUM
    !
    !  YY is 1 - XX
    !
    !  Calculate the smaller of XX and YY accurately.
    !
    dsum = dfd + prod
    xx = dfd / dsum

    if ( 0.5D+00 < xx ) then
        yy = prod / dsum
        xx = 1.0D+00 - yy
    else
        yy = 1.0D+00 - xx
    end if

    call beta_inc ( 0.5D+00 * dfd, 0.5D+00 * dfn, xx, yy, ccum, cum, ierr )

    return
    end
    subroutine cumfnc ( f, dfn, dfd, pnonc, cum, ccum )

    !*****************************************************************************80
    !
    !! CUMFNC evaluates the cumulative noncentral F distribution.
    !
    !  Discussion:
    !
    !    This routine computes the noncentral F distribution with DFN and DFD
    !    degrees of freedom and noncentrality parameter PNONC.
    !
    !    The series is calculated backward and forward from J = LAMBDA/2
    !    (this is the term with the largest Poisson weight) until
    !    the convergence criterion is met.
    !
    !    The sum continues until a succeeding term is less than EPS
    !    times the sum or the sum is very small.  EPS is
    !    set to 1.0D-4 in a data statement which can be changed.
    !
    !    The original version of this routine allowed the input values
    !    of DFN and DFD to be negative (nonsensical) or zero (which
    !    caused numerical overflow.)  I have forced both these values
    !    to be at least 1.
    !
    !  Modified:
    !
    !    19 May 2007
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions
    !    1966, Formula 26.5.16, 26.6.17, 26.6.18, 26.6.20.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) F, the upper limit of integration.
    !
    !    Input, real ( kind = 8 ) DFN, DFD, the number of degrees of freedom
    !    in the numerator and denominator.  Both DFN and DFD must be positive,
    !    and normally would be integers.  This routine requires that they
    !    be no less than 1.
    !
    !    Input, real ( kind = 8 ) PNONC, the noncentrality parameter.
    !
    !    Output, real ( kind = 8 ) CUM, CCUM, the noncentral F CDF and
    !    complementary CDF.
    !
    implicit none

    real ( kind = 8 ) adn
    real ( kind = 8 ) arg1
    real ( kind = 8 ) aup
    real ( kind = 8 ) b
    real ( kind = 8 ) betdn
    real ( kind = 8 ) betup
    real ( kind = 8 ) centwt
    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) dfd
    real ( kind = 8 ) dfn
    real ( kind = 8 ) dnterm
    real ( kind = 8 ) dsum
    real ( kind = 8 ) dummy
    real ( kind = 8 ), parameter :: eps = 0.0001D+00
    real ( kind = 8 ) expon
    real ( kind = 8 ) f
    real ( kind = 8 ) gamma_log
    integer ( kind = 4 ) i
    integer ( kind = 4 ) icent
    integer ( kind = 4 ) ierr
    real ( kind = 8 ) pnonc
    real ( kind = 8 ) prod
    real ( kind = 8 ) sum1
    real ( kind = 8 ) upterm
    real ( kind = 8 ) x
    real ( kind = 8 ) xmult
    real ( kind = 8 ) xnonc
    real ( kind = 8 ) xx
    real ( kind = 8 ) yy

    if ( f <= 0.0D+00 ) then
        cum = 0.0D+00
        ccum = 1.0D+00
        return
    end if

    if ( dfn < 1.0D+00 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CUMFNC - Fatal error!'
        write ( *, '(a)' ) '  DFN < 1.'
        stop
    end if

    if ( dfd < 1.0D+00 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CUMFNC - Fatal error!'
        write ( *, '(a)' ) '  DFD < 1.'
        stop
    end if
    !
    !  Handle case in which the noncentrality parameter is essentially zero.
    !
    if ( pnonc < 1.0D-10 ) then
        call cumf ( f, dfn, dfd, cum, ccum )
        return
    end if

    xnonc = pnonc /  2.0D+00
    !
    !  Calculate the central term of the Poisson weighting factor.
    !
    icent = int ( xnonc )

    if ( icent == 0 ) then
        icent = 1
    end if
    !
    !  Compute central weight term.
    !
    centwt = exp ( -xnonc + icent * log ( xnonc ) &
        - gamma_log ( real ( icent + 1, kind = 8  ) ) )
    !
    !  Compute central incomplete beta term.
    !  Ensure that minimum of arg to beta and 1 - arg is computed accurately.
    !
    prod = dfn * f
    dsum = dfd + prod
    yy = dfd / dsum

    if ( 0.5D+00 < yy ) then
        xx = prod / dsum
        yy = 1.0D+00 - xx
    else
        xx = 1.0D+00 - yy
    end if

    arg1 = 0.5D+00 * dfn + real ( icent, kind = 8 )
    call beta_inc ( arg1, 0.5D+00*dfd, xx, yy, betdn, dummy, ierr )

    adn = dfn / 2.0D+00 + real ( icent, kind = 8 )
    aup = adn
    b = dfd / 2.0D+00
    betup = betdn
    sum1 = centwt * betdn
    !
    !  Now sum terms backward from ICENT until convergence or all done.
    !
    xmult = centwt
    i = icent
    dnterm = exp ( gamma_log ( adn + b ) &
        - gamma_log ( adn + 1.0D+00 ) &
        - gamma_log ( b ) + adn * log ( xx ) + b * log ( yy ) )

    do

        if ( i <= 0 ) then
            exit
        end if

        if ( sum1 < epsilon ( xmult * betdn ) .or. &
            xmult * betdn < eps * sum1 ) then
            exit
        end if

        xmult = xmult * ( real ( i, kind = 8 ) / xnonc )
        i = i - 1
        adn = adn - 1.0D+00
        dnterm = ( adn + 1.0D+00 ) / ( ( adn + b ) * xx ) * dnterm
        betdn = betdn + dnterm
        sum1 = sum1 + xmult * betdn

    end do

    i = icent + 1
    !
    !  Now sum forward until convergence.
    !
    xmult = centwt

    if ( ( aup - 1.0D+00 + b ) == 0 ) then

        expon = - gamma_log ( aup ) - gamma_log ( b ) &
            + ( aup - 1.0D+00 ) * log ( xx ) + b * log ( yy )

    else

        expon = gamma_log ( aup - 1.0D+00 + b ) - gamma_log ( aup ) &
            - gamma_log ( b ) + ( aup - 1.0D+00 ) * log ( xx ) + b * log ( yy )

    end if
    !
    !  The fact that DCDFLIB blithely assumes that 1.0E+30 is a reasonable
    !  value to plug into any function, and that G95 computes corresponding
    !  function values of, say 1.0E-303, and then chokes with a floating point
    !  error when asked to combine such a value with a reasonable floating
    !  point quantity, has driven me to the following sort of check that
    !  was last fashionable in the 1960's!
    !
    if ( expon <= log ( epsilon ( expon ) ) ) then
        upterm = 0.0D+00
    else
        upterm = exp ( expon )
    end if

    do

        xmult = xmult * ( xnonc / real ( i, kind = 8 ) )
        i = i + 1
        aup = aup + 1.0D+00
        upterm = ( aup + b -  2.0D+00  ) * xx / ( aup - 1.0D+00 ) * upterm
        betup = betup - upterm
        sum1 = sum1 + xmult * betup

        if ( sum1 < epsilon ( xmult * betup ) .or. xmult * betup < eps * sum1 ) then
            exit
        end if

    end do

    cum = sum1
    ccum = 0.5D+00 + ( 0.5D+00 - cum )

    return
    end
    subroutine cumgam ( x, a, cum, ccum )

    !*****************************************************************************80
    !
    !! CUMGAM evaluates the cumulative incomplete gamma distribution.
    !
    !  Discussion:
    !
    !    This routine computes the cumulative distribution function of the
    !    incomplete gamma distribution, i.e., the integral from 0 to X of
    !
    !      (1/GAM(A))*EXP(-T)*T^(A-1) DT
    !
    !    where GAM(A) is the complete gamma function of A:
    !
    !      GAM(A) = integral from 0 to infinity of EXP(-T)*T^(A-1) DT
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) X, the upper limit of integration.
    !
    !    Input, real ( kind = 8 ) A, the shape parameter of the incomplete
    !    Gamma distribution.
    !
    !    Output, real ( kind = 8 ) CUM, CCUM, the incomplete Gamma CDF and
    !    complementary CDF.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) x

    if ( x <= 0.0D+00 ) then

        cum = 0.0D+00
        ccum = 1.0D+00

    else

        call gamma_inc ( a, x, cum, ccum, 0 )

    end if

    return
    end
    subroutine cumnbn ( f, s, pr, ompr, cum, ccum )

    !*****************************************************************************80
    !
    !! CUMNBN evaluates the cumulative negative binomial distribution.
    !
    !  Discussion:
    !
    !    This routine returns the probability that there will be F or
    !    fewer failures before there are S successes, with each binomial
    !    trial having a probability of success PR.
    !
    !    Prob(# failures = F | S successes, PR)  =
    !                        ( S + F - 1 )
    !                        (            ) * PR^S * (1-PR)^F
    !                        (      F     )
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions
    !    1966, Formula 26.5.26.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) F, the number of failures.
    !
    !    Input, real ( kind = 8 ) S, the number of successes.
    !
    !    Input, real ( kind = 8 ) PR, OMPR, the probability of success on
    !    each binomial trial, and the value of (1-PR).
    !
    !    Output, real ( kind = 8 ) CUM, CCUM, the negative binomial CDF,
    !    and the complementary CDF.
    !
    implicit none

    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) f
    real ( kind = 8 ) ompr
    real ( kind = 8 ) pr
    real ( kind = 8 ) s

    call cumbet ( pr, ompr, s, f+1.D+00, cum, ccum )

    return
    end
    subroutine cumnor ( arg, cum, ccum )

    !*****************************************************************************80
    !
    !! CUMNOR computes the cumulative normal distribution.
    !
    !  Discussion:
    !
    !    This function evaluates the normal distribution function:
    !
    !                              / x
    !                     1       |       -t*t/2
    !          P(x) = ----------- |      e       dt
    !                 sqrt(2 pi)  |
    !                             /-oo
    !
    !    This transportable program uses rational functions that
    !    theoretically approximate the normal distribution function to
    !    at least 18 significant decimal digits.  The accuracy achieved
    !    depends on the arithmetic system, the compiler, the intrinsic
    !    functions, and proper selection of the machine dependent
    !    constants.
    !
    !  Author:
    !
    !    William Cody
    !    Mathematics and Computer Science Division
    !    Argonne National Laboratory
    !    Argonne, IL 60439
    !
    !  Reference:
    !
    !    William Cody,
    !    Rational Chebyshev approximations for the error function,
    !    Mathematics of Computation,
    !    1969, pages 631-637.
    !
    !    William Cody,
    !    Algorithm 715:
    !    SPECFUN - A Portable FORTRAN Package of Special Function Routines
    !    and Test Drivers,
    !    ACM Transactions on Mathematical Software,
    !    Volume 19, Number 1, 1993, pages 22-32.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) ARG, the upper limit of integration.
    !
    !    Output, real ( kind = 8 ) CUM, CCUM, the Normal density CDF and
    !    complementary CDF.
    !
    !  Local Parameters:
    !
    !    Local, real ( kind = 8 ) EPS, the argument below which anorm(x)
    !    may be represented by 0.5 and above which  x*x  will not underflow.
    !    A conservative value is the largest machine number X
    !    such that   1.0D+00 + X = 1.0D+00   to machine precision.
    !
    implicit none

    real ( kind = 8 ), parameter, dimension ( 5 ) :: a = (/ &
        2.2352520354606839287D+00, &
        1.6102823106855587881D+02, &
        1.0676894854603709582D+03, &
        1.8154981253343561249D+04, &
        6.5682337918207449113D-02 /)
    real ( kind = 8 ) arg
    real ( kind = 8 ), parameter, dimension ( 4 ) :: b = (/ &
        4.7202581904688241870D+01, &
        9.7609855173777669322D+02, &
        1.0260932208618978205D+04, &
        4.5507789335026729956D+04 /)
    real ( kind = 8 ), parameter, dimension ( 9 ) :: c = (/ &
        3.9894151208813466764D-01, &
        8.8831497943883759412D+00, &
        9.3506656132177855979D+01, &
        5.9727027639480026226D+02, &
        2.4945375852903726711D+03, &
        6.8481904505362823326D+03, &
        1.1602651437647350124D+04, &
        9.8427148383839780218D+03, &
        1.0765576773720192317D-08 /)
    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ), parameter, dimension ( 8 ) :: d = (/ &
        2.2266688044328115691D+01, &
        2.3538790178262499861D+02, &
        1.5193775994075548050D+03, &
        6.4855582982667607550D+03, &
        1.8615571640885098091D+04, &
        3.4900952721145977266D+04, &
        3.8912003286093271411D+04, &
        1.9685429676859990727D+04 /)
    real ( kind = 8 ) del
    real ( kind = 8 ) eps
    integer ( kind = 4 ) i
    real ( kind = 8 ), parameter, dimension ( 6 ) :: p = (/ &
        2.1589853405795699D-01, &
        1.274011611602473639D-01, &
        2.2235277870649807D-02, &
        1.421619193227893466D-03, &
        2.9112874951168792D-05, &
        2.307344176494017303D-02 /)
    real ( kind = 8 ), parameter, dimension ( 5 ) :: q = (/ &
        1.28426009614491121D+00, &
        4.68238212480865118D-01, &
        6.59881378689285515D-02, &
        3.78239633202758244D-03, &
        7.29751555083966205D-05 /)
    real ( kind = 8 ), parameter :: root32 = 5.656854248D+00
    real ( kind = 8 ), parameter :: sixten = 16.0D+00
    real ( kind = 8 ) temp
    real ( kind = 8 ), parameter :: sqrpi = 3.9894228040143267794D-01
    real ( kind = 8 ), parameter :: thrsh = 0.66291D+00
    real ( kind = 8 ) x
    real ( kind = 8 ) xden
    real ( kind = 8 ) xnum
    real ( kind = 8 ) y
    real ( kind = 8 ) xsq
    !
    !  Machine dependent constants
    !
    eps = epsilon ( 1.0D+00 ) * 0.5D+00

    x = arg
    y = abs ( x )

    if ( y <= thrsh ) then
        !
        !  Evaluate  anorm  for  |X| <= 0.66291
        !
        if ( eps < y ) then
            xsq = x * x
        else
            xsq = 0.0D+00
        end if

        xnum = a(5) * xsq
        xden = xsq
        do i = 1, 3
            xnum = ( xnum + a(i) ) * xsq
            xden = ( xden + b(i) ) * xsq
        end do
        cum = x * ( xnum + a(4) ) / ( xden + b(4) )
        temp = cum
        cum = 0.5D+00 + temp
        ccum = 0.5D+00 - temp
        !
        !  Evaluate ANORM for 0.66291 <= |X| <= sqrt(32)
        !
    else if ( y <= root32 ) then

        xnum = c(9) * y
        xden = y
        do i = 1, 7
            xnum = ( xnum + c(i) ) * y
            xden = ( xden + d(i) ) * y
        end do
        cum = ( xnum + c(8) ) / ( xden + d(8) )
        xsq = aint ( y * sixten ) / sixten
        del = ( y - xsq ) * ( y + xsq )
        cum = exp ( - xsq * xsq * 0.5D+00 ) * exp ( -del * 0.5D+00 ) * cum
        ccum = 1.0D+00 - cum

        if ( 0.0D+00 < x ) then
            call r8_swap ( cum, ccum )
        end if
        !
        !  Evaluate ANORM for sqrt(32) < |X|.
        !
    else

        cum = 0.0D+00
        xsq = 1.0D+00 / ( x * x )
        xnum = p(6) * xsq
        xden = xsq
        do i = 1, 4
            xnum = ( xnum + p(i) ) * xsq
            xden = ( xden + q(i) ) * xsq
        end do

        cum = xsq * ( xnum + p(5) ) / ( xden + q(5) )
        cum = ( sqrpi - cum ) / y
        xsq = aint ( x * sixten ) / sixten
        del = ( x - xsq ) * ( x + xsq )
        cum = exp ( - xsq * xsq * 0.5D+00 ) &
            * exp ( - del * 0.5D+00 ) * cum
        ccum = 1.0D+00 - cum

        if ( 0.0D+00 < x ) then
            call r8_swap ( cum, ccum )
        end if

    end if

    if ( cum < tiny ( cum ) ) then
        cum = 0.0D+00
    end if

    if ( ccum < tiny ( ccum ) ) then
        ccum = 0.0D+00
    end if

    return
    end
    subroutine cumpoi ( s, xlam, cum, ccum )

    !*****************************************************************************80
    !
    !! CUMPOI evaluates the cumulative Poisson distribution.
    !
    !  Discussion:
    !
    !    This routine returns the probability of S or fewer events in a Poisson
    !    distribution with mean XLAM.
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions,
    !    Formula 26.4.21.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) S, the upper limit of cumulation of the
    !    Poisson density function.
    !
    !    Input, real ( kind = 8 ) XLAM, the mean of the Poisson distribution.
    !
    !    Output, real ( kind = 8 ) CUM, CCUM, the Poisson density CDF and
    !    complementary CDF.
    !
    implicit none

    real ( kind = 8 ) ccum
    real ( kind = 8 ) chi
    real ( kind = 8 ) cum
    real ( kind = 8 ) df
    real ( kind = 8 ) s
    real ( kind = 8 ) xlam

    df =  2.0D+00  * ( s + 1.0D+00 )
    chi =  2.0D+00  * xlam

    call cumchi ( chi, df, ccum, cum )

    return
    end
    subroutine cumt ( t, df, cum, ccum )

    !*****************************************************************************80
    !
    !! CUMT evaluates the cumulative T distribution.
    !
    !  Author:
    !
    !    Barry Brown, James Lovato, Kathy Russell
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions,
    !    Formula 26.5.27.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) T, the upper limit of integration.
    !
    !    Input, real ( kind = 8 ) DF, the number of degrees of freedom of
    !    the T distribution.
    !
    !    Output, real ( kind = 8 ) CUM, CCUM, the T distribution CDF and
    !    complementary CDF.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) df
    real ( kind = 8 ) oma
    real ( kind = 8 ) t
    real ( kind = 8 ) xx
    real ( kind = 8 ) yy

    xx = df / ( df + t**2 )
    yy = t**2 / ( df + t**2 )

    call cumbet ( xx, yy, 0.5D+00*df, 0.5D+00, a, oma )

    if ( t <= 0.0D+00 ) then
        cum = 0.5D+00 * a
        ccum = oma + cum
    else
        ccum = 0.5D+00 * a
        cum = oma + ccum
    end if

    return
    end
    function dbetrm ( a, b )

    !*****************************************************************************80
    !
    !! DBETRM computes the Sterling remainder for the complete beta function.
    !
    !  Discussion:
    !
    !    Log(Beta(A,B)) = Lgamma(A) + Lgamma(B) - Lgamma(A+B)
    !    where Lgamma is the log of the (complete) gamma function
    !
    !    Let ZZ be approximation obtained if each log gamma is approximated
    !    by Sterling's formula, i.e.,
    !
    !      Sterling(Z) = log ( sqrt ( 2 * PI ) ) + ( Z - 0.5 ) * log ( Z ) - Z
    !
    !    The Sterling remainder is Log(Beta(A,B)) - ZZ.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, B, the parameters of the Beta function.
    !
    !    Output, real ( kind = 8 ) DBETRM, the Sterling remainder.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) b
    real ( kind = 8 ) dbetrm
    real ( kind = 8 ) dstrem
    !
    !  Try to sum from smallest to largest.
    !
    dbetrm = -dstrem ( a + b )
    dbetrm = dbetrm + dstrem ( max ( a, b ) )
    dbetrm = dbetrm + dstrem ( min ( a, b ) )

    return
    end
    function dexpm1 ( x )

    !*****************************************************************************80
    !
    !! DEXPM1 evaluates the function EXP(X) - 1.
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) X, the value at which exp(X)-1 is desired.
    !
    !    Output, real ( kind = 8 ) DEXPM1, the value of exp(X)-1.
    !
    implicit none

    real ( kind = 8 ) bot
    real ( kind = 8 ) dexpm1
    real ( kind = 8 ), parameter :: p1 =  0.914041914819518D-09
    real ( kind = 8 ), parameter :: p2 =  0.238082361044469D-01
    real ( kind = 8 ), parameter :: q1 = -0.499999999085958D+00
    real ( kind = 8 ), parameter :: q2 =  0.107141568980644D+00
    real ( kind = 8 ), parameter :: q3 = -0.119041179760821D-01
    real ( kind = 8 ), parameter :: q4 =  0.595130811860248D-03
    real ( kind = 8 ) top
    real ( kind = 8 ) w
    real ( kind = 8 ) x

    if ( abs ( x ) <= 0.15D+00 ) then

        top = ( p2 * x + p1 ) * x + 1.0D+00
        bot = ((( q4 * x + q3 ) * x + q2 ) * x + q1 ) * x + 1.0D+00
        dexpm1 = x * ( top / bot )

    else

        w = exp ( x )

        if ( x <= 0.0D+00 ) then
            dexpm1 = ( w - 0.5D+00 ) - 0.5D+00
        else
            dexpm1 = w * ( 0.5D+00 &
                + ( 0.5D+00 - 1.0D+00 / w ))
        end if

    end if

    return
    end
    function dinvnr ( p, q )

    !*****************************************************************************80
    !
    !! DINVNR computes the inverse of the normal distribution.
    !
    !  Discussion:
    !
    !    This routine returns X such that
    !
    !      CUMNOR(X) = P,
    !
    !    that is, so that
    !
    !      P = integral ( -oo <= T <= X ) exp(-U*U/2)/sqrt(2*PI) dU
    !
    !    The rational function on page 95 of Kennedy and Gentle is used as a
    !    starting value for the Newton method of finding roots.
    !
    !  Reference:
    !
    !    William Kennedy, James Gentle,
    !    Statistical Computing,
    !    Marcel Dekker, NY, 1980,
    !    QA276.4 K46
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) P, Q, the probability, and the complementary
    !    probability.
    !
    !    Output, real ( kind = 8 ) DINVNR, the argument X for which the
    !    Normal CDF has the value P.
    !
    implicit none

    real ( kind = 8 ) ccum
    real ( kind = 8 ) cum
    real ( kind = 8 ) dinvnr
    real ( kind = 8 ) dx
    real ( kind = 8 ), parameter :: eps = 1.0D-13
    integer ( kind = 4 ) i
    integer ( kind = 4 ), parameter :: maxit = 100
    real ( kind = 8 ) p
    real ( kind = 8 ) pp
    real ( kind = 8 ) q
    real ( kind = 8 ), parameter :: r2pi = 0.3989422804014326D+00
    real ( kind = 8 ) strtx
    real ( kind = 8 ) stvaln
    real ( kind = 8 ) xcur

    pp = min ( p, q )
    strtx = stvaln ( pp )
    xcur = strtx
    !
    !  Newton iterations.
    !
    do i = 1, maxit

        call cumnor ( xcur, cum, ccum )
        dx = ( cum - pp ) / ( r2pi * exp ( -0.5D+00 * xcur * xcur ) )
        xcur = xcur - dx

        if ( abs ( dx / xcur ) < eps ) then
            if ( p <= q ) then
                dinvnr = xcur
            else
                dinvnr = -xcur
            end if
            return
        end if

    end do

    if ( p <= q ) then
        dinvnr = strtx
    else
        dinvnr = -strtx
    end if

    return
    end
    subroutine dinvr ( status, x, fx, qleft, qhi )

    !*****************************************************************************80
    !
    !! DINVR bounds the zero of the function and invokes DZROR.
    !
    !  Discussion:
    !
    !    This routine seeks to find bounds on a root of the function and
    !    invokes DZROR to perform the zero finding.  DSTINV must have been
    !    called before this routine in order to set its parameters.
    !
    !  Reference:
    !
    !    JCP Bus, TJ Dekker,
    !    Two Efficient Algorithms with Guaranteed Convergence for
    !    Finding a Zero of a Function,
    !    ACM Transactions on Mathematical Software,
    !    Volume 1, Number 4, pages 330-345, 1975.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) STATUS.  At the beginning of a zero
    !    finding problem, STATUS should be set to 0 and this routine invoked.
    !    The value of parameters other than X will be ignored on this call.
    !    If this routine needs the function to be evaluated, it will set STATUS
    !    to 1 and return.  The value of the function should be set in FX and
    !    this routine again called without changing any of its other parameters.
    !    If this routine finishes without error, it returns with STATUS 0,
    !    and X an approximate root of F(X).
    !    If this routine cannot bound the function, it returns a negative STATUS and
    !    sets QLEFT and QHI.
    !
    !    Output, real ( kind = 8 ) X, the value at which F(X) is to be evaluated.
    !
    !    Input, real ( kind = 8 ) FX, the value of F(X) calculated by the user
    !    on the previous call, when this routine returned with STATUS = 1.
    !
    !    Output, logical QLEFT, is defined only if QMFINV returns FALSE.  In that
    !    case, QLEFT is TRUE if the stepping search terminated unsucessfully
    !    at SMALL, and FALSE if the search terminated unsucessfully at BIG.
    !
    !    Output, logical QHI, is defined only if QMFINV returns FALSE.  In that
    !    case, it is TRUE if Y < F(X) at the termination of the search and FALSE
    !    if F(X) < Y.
    !
    implicit none

    real ( kind = 8 ) :: absstp
    real ( kind = 8 ) :: abstol
    real ( kind = 8 ) :: big
    real ( kind = 8 ) fbig
    real ( kind = 8 ) fsmall
    real ( kind = 8 ) fx
    integer ( kind = 4 ) i99999
    logical qbdd
    logical qcond
    logical qdum1
    logical qdum2
    logical qhi
    logical qincr
    logical qleft
    logical qlim
    logical qup
    real ( kind = 8 ) :: relstp
    real ( kind = 8 ) :: reltol
    real ( kind = 8 ) :: small
    integer ( kind = 4 ) status
    real ( kind = 8 ) step
    real ( kind = 8 ) :: stpmul
    real ( kind = 8 ) x
    real ( kind = 8 ) xhi
    real ( kind = 8 ) xlb
    real ( kind = 8 ) xlo
    real ( kind = 8 ) xsave
    real ( kind = 8 ) xub
    real ( kind = 8 ) yy
    real ( kind = 8 ) zabsst
    real ( kind = 8 ) zabsto
    real ( kind = 8 ) zbig
    real ( kind = 8 ) zrelst
    real ( kind = 8 ) zrelto
    real ( kind = 8 ) zsmall
    real ( kind = 8 ) zstpmu

    save

    if ( 0 < status ) then
        go to i99999
    end if

    qcond = .not. ( small <= x .and. x <= big )

    if ( .not. ( small <= x .and. x <= big ) ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'DINVR - Fatal error!'
        write ( *, '(a)' ) '  The values SMALL, X, BIG are not monotone.'
        stop
    end if

    xsave = x
    !
    !  See that SMALL and BIG bound the zero and set QINCR.
    !
    x = small
    !
    !  GET-function-VALUE
    !
    assign 10 to i99999
    status = 1
    return

10  continue

    fsmall = fx
    x = big
    !
    !  GET-function-VALUE
    !
    assign 20 to i99999
    status = 1
    return

20  continue

    fbig = fx

    qincr = ( fsmall < fbig )

    if ( fsmall <= fbig ) then

        if ( 0.0D+00 < fsmall ) then
            status = -1
            qleft = .true.
            qhi = .true.
            return
        end if

        if ( fbig < 0.0D+00 ) then
            status = -1
            qleft = .false.
            qhi = .false.
            return
        end if

    else if ( fbig < fsmall ) then

        if ( fsmall < 0.0D+00 ) then
            status = -1
            qleft = .true.
            qhi = .false.
            return
        end if

        if ( 0.0D+00 < fbig ) then
            status = -1
            qleft = .false.
            qhi = .true.
            return
        end if

    end if

    x = xsave
    step = max ( absstp, relstp * abs ( x ) )
    !
    !  YY = F(X) - Y
    !  GET-function-VALUE
    !
    assign 90 to i99999
    status = 1
    return

90  continue

    yy = fx

    if ( yy == 0.0D+00 ) then
        status = 0
        return
    end if

100 continue

    qup = ( qincr .and. ( yy < 0.0D+00 ) ) .or. &
        ( .not. qincr .and. ( 0.0D+00 < yy ) )
    !
    !  Handle case in which we must step higher.
    !
    if (.not. qup ) then
        go to 170
    end if

    xlb = xsave
    xub = min ( xlb + step, big )
    go to 120

110 continue

    if ( qcond ) then
        go to 150
    end if
    !
    !  YY = F(XUB) - Y
    !
120 continue

    x = xub
    !
    !  GET-function-VALUE
    !
    assign 130 to i99999
    status = 1
    return

130 continue

    yy = fx
    qbdd = ( qincr .and. ( 0.0D+00 <= yy ) ) .or. &
        ( .not. qincr .and. ( yy <= 0.0D+00 ) )
    qlim = ( big <= xub )
    qcond = qbdd .or. qlim

    if ( .not. qcond ) then
        step = stpmul * step
        xlb = xub
        xub = min ( xlb + step, big )
    end if

    go to 110

150 continue

    if ( qlim .and. .not. qbdd ) then
        status = -1
        qleft = .false.
        qhi = .not. qincr
        x = big
        return
    end if

160 continue

    go to 240
    !
    !  Handle the case in which we must step lower.
    !
170 continue

    xub = xsave
    xlb = max ( xub - step, small )
    go to 190

180 continue

    if ( qcond ) then
        go to 220
    end if
    !
    !  YY = F(XLB) - Y
    !
190 continue

    x = xlb
    !
    !  GET-function-VALUE
    !
    assign 200 to i99999
    status = 1
    return

200 continue

    yy = fx
    qbdd = ( qincr .and. ( yy <= 0.0D+00 ) ) .or. &
        ( .not. qincr .and. ( 0.0D+00 <= yy ) )
    qlim = xlb <= small
    qcond = qbdd .or. qlim

    if ( .not. qcond ) then
        step = stpmul * step
        xub = xlb
        xlb = max ( xub - step, small )
    end if

    go to 180

220 continue

    if ( qlim .and. ( .not. qbdd ) ) then
        status = -1
        qleft = .true.
        qhi = qincr
        x = small
        return
    end if

230 continue
240 continue

    call dstzr ( xlb, xub, abstol, reltol )
    !
    !  If we reach here, XLB and XUB bound the zero of F.
    !
    status = 0
    go to 260

250 continue

    if ( status /= 1 ) then
        x = xlo
        status = 0
        return
    end if

260 continue

    call dzror ( status, x, fx, xlo, xhi, qdum1, qdum2 )

    if ( status /= 1 ) then
        go to 250
    end if
    !
    !  GET-function-VALUE
    !
    assign 270 to i99999
    status = 1
    return

270 continue
    go to 250

    entry dstinv ( zsmall, zbig, zabsst, zrelst, zstpmu, zabsto, zrelto )

    !*****************************************************************************80
    !
    !! DSTINV SeT INverse finder - Reverse Communication
    !
    !  Discussion:
    !
    !    This routine is given a monotone function F, and a value Y,
    !    and seeks an argument value X such that F(X) = Y.
    !
    !    This routine uses reverse communication -- see DINVR.
    !    This routine sets quantities needed by DINVR.
    !
    !    F must be a monotone function, the results of QMFINV are
    !    otherwise undefined.  QINCR must be TRUE if F is nondecreasing
    !    and FALSE if F is nonincreasing.
    !
    !    QMFINV will return TRUE if and only if F(SMALL) and
    !    F(BIG) bracket Y, i. e.,
    !      QINCR is TRUE and F(SMALL) <= Y <= F(BIG) or
    !      QINCR is FALSE and F(BIG) <= Y <= F(SMALL)
    !
    !    If QMFINV returns TRUE, then the X returned satisfies
    !    the following condition.  Let
    !      TOL(X) = MAX ( ABSTOL, RELTOL * ABS ( X ) )
    !    then if QINCR is TRUE,
    !      F(X-TOL(X)) <= Y <= F(X+TOL(X))
    !    and if QINCR is FALSE
    !      F(X-TOL(X)) .GE. Y .GE. F(X+TOL(X))
    !
    !    Compares F(X) with Y for the input value of X then uses QINCR
    !    to determine whether to step left or right to bound the
    !    desired X.  The initial step size is
    !
    !      max ( ABSSTP, RELSTP * ABS ( S ) )
    !
    !    for the input value of X.
    !
    !    Iteratively steps right or left until it bounds X.
    !    At each step which doesn't bound X, the step size is doubled.
    !    The routine is careful never to step beyond SMALL or BIG.  If
    !    it hasn't bounded X at SMALL or BIG, QMFINV returns FALSE
    !    after setting QLEFT and QHI.
    !
    !    If X is successfully bounded then Algorithm R of the paper
    !    Bus and Dekker is employed to find the zero of the function F(X)-Y.
    !    This is routine QRZERO.
    !
    !  Reference:
    !
    !    JCP Bus, TJ Dekker,
    !    Two Efficient Algorithms with Guaranteed Convergence for
    !    Finding a Zero of a Function,
    !    ACM Transactions on Mathematical Software,
    !    Volume 1, Number 4, pages 330-345, 1975.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) ZSMALL, ZBIG, the left and right endpoints
    !    of the interval to be searched for a solution.
    !
    !    Input, real ( kind = 8 ) ZABSST, ZRELSTP, the initial step size in
    !    the search is max ( ZABSST, ZRELST * abs ( X ) ).
    !
    !    Input, real ( kind = 8 ) STPMUL.  When a step doesn't bound the zero,
    !    the stepsize is multiplied by STPMUL and another step taken.  A
    !    popular value is 2.0.
    !
    !    Input, real ( kind = 8 ) ABSTOL, RELTOL, two numbers that determine
    !    the accuracy of the solution
    !
    small = zsmall
    big = zbig
    absstp = zabsst
    relstp = zrelst
    stpmul = zstpmu
    abstol = zabsto
    reltol = zrelto

    return
    end
    function dlanor ( x )

    !*****************************************************************************80
    !
    !! DLANOR evaluates the logarithm of the asymptotic Normal CDF.
    !
    !  Discussion:
    !
    !    This routine computes the logarithm of the cumulative normal distribution
    !    from abs ( x ) to infinity for  5 <= abs ( X ).
    !
    !    The relative error at X = 5 is about 0.5D-5.
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions
    !    1966, Formula 26.2.12.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) X, the value at which the Normal CDF is to be
    !    evaluated.  It is assumed that 5 <= abs ( X ).
    !
    !    Output, real ( kind = 8 ) DLANOR, the logarithm of the asymptotic
    !    Normal CDF.
    !
    implicit none

    real ( kind = 8 ) alnrel
    real ( kind = 8 ) approx
    real ( kind = 8 ), save, dimension ( 0:11 ) :: coef = (/ &
        -1.0D+00,  3.0D+00,  -15.0D+00,  105.0D+00,  -945.0D+00,  &
        10395.0D+00, -135135.0D+00,  2027025.0D+00,  -34459425.0D+00, &
        654729075.0D+00, -13749310575D+00,  316234143225.0D+00 /)
    real ( kind = 8 ) correc
    real ( kind = 8 ), parameter :: dlsqpi = 0.91893853320467274177D+00
    real ( kind = 8 ) eval_pol
    real ( kind = 8 ) dlanor
    real ( kind = 8 ) x
    real ( kind = 8 ) xx
    real ( kind = 8 ) xx2

    xx = abs ( x )

    if ( abs ( x ) < 5.0D+00 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'DLANOR - Fatal error!'
        write ( *, '(a)' ) '  The argument X is too small.'
    end if

    approx = - dlsqpi - 0.5D+00 * x**2 - log ( abs ( x ) )

    xx2 = xx * xx
    correc = eval_pol ( coef, 11, 1.0D+00 / xx2 ) / xx2
    correc = alnrel ( correc )

    dlanor = approx + correc

    return
    end
    function dstrem ( z )

    !*****************************************************************************80
    !
    !! DSTREM computes the Sterling remainder ln ( Gamma ( Z ) ) - Sterling ( Z ).
    !
    !  Discussion:
    !
    !    This routine returns
    !
    !      ln ( Gamma ( Z ) ) - Sterling ( Z )
    !
    !    where Sterling(Z) is Sterling's approximation to ln ( Gamma ( Z ) ).
    !
    !    Sterling(Z) = ln ( sqrt ( 2 * PI ) ) + ( Z - 0.5 ) * ln ( Z ) - Z
    !
    !    If 6 <= Z, the routine uses 9 terms of a series in Bernoulli numbers,
    !    with values calculated using Maple.
    !
    !    Otherwise, the difference is computed explicitly.
    !
    !  Modified:
    !
    !    14 June 2004
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) Z, the value at which the Sterling
    !    remainder is to be calculated.  Z must be positive.
    !
    !    Output, real ( kind = 8 ) DSTREM, the Sterling remainder.
    !
    implicit none

    integer ( kind = 4 ), parameter :: ncoef = 9

    real ( kind = 8 ), parameter, dimension ( 0:ncoef ) :: coef = (/ &
        0.0D+00, &
        0.0833333333333333333333333333333D+00, &
        -0.00277777777777777777777777777778D+00, &
        0.000793650793650793650793650793651D+00, &
        -0.000595238095238095238095238095238D+00, &
        0.000841750841750841750841750841751D+00, &
        -0.00191752691752691752691752691753D+00, &
        0.00641025641025641025641025641026D+00, &
        -0.0295506535947712418300653594771D+00, &
        0.179644372368830573164938490016D+00 /)
    real ( kind = 8 ) dstrem
    real ( kind = 8 ) eval_pol
    real ( kind = 8 ) gamma_log
    real ( kind = 8 ), parameter :: hln2pi = 0.91893853320467274178D+00
    real ( kind = 8 ) sterl
    real ( kind = 8 ) z

    if ( z <= 0.0D+00 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'DSTREM - Fatal error!'
        write ( *, '(a)' ) '  Zero or negative argument Z.'
        stop
    end if

    if ( 6.0D+00 < z ) then
        dstrem = eval_pol ( coef, ncoef, 1.0D+00 / z**2 ) * z
    else
        sterl = hln2pi + ( z - 0.5D+00 ) * log ( z ) - z
        dstrem = gamma_log ( z ) - sterl
    end if

    return
    end
    function dt1 ( p, q, df )

    !*****************************************************************************80
    !
    !! DT1 computes an approximate inverse of the cumulative T distribution.
    !
    !  Discussion:
    !
    !    This routine returns the inverse of the T distribution function, that is,
    !    the integral from 0 to INVT of the T density is P.  This is an
    !    initial approximation.
    !
    !    Thanks to Charles Katholi for pointing out that the RESHAPE
    !    function should not use a range in the "SHAPE" field (0:4,4),
    !    but simply the number of rows and columns (5,4), JVB, 04 May 2006.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) P, Q, the value whose inverse from the
    !    T distribution CDF is desired, and the value (1-P).
    !
    !    Input, real ( kind = 8 ) DF, the number of degrees of freedom of the
    !    T distribution.
    !
    !    Output, real ( kind = 8 ) DT1, the approximate value of X for which
    !    the T density CDF with DF degrees of freedom has value P.
    !
    implicit none

    real ( kind = 8 ), dimension(0:4,4) :: coef = reshape ( (/ &
        1.0D+00,     1.0D+00,    0.0D+00,   0.0D+00,  0.0D+00, &
        3.0D+00,    16.0D+00,    5.0D+00,   0.0D+00,  0.0D+00, &
        -15.0D+00,    17.0D+00,   19.0D+00,   3.0D+00,  0.0D+00, &
        -945.0D+00, -1920.0D+00, 1482.0D+00, 776.0D+00, 79.0D+00/), (/ 5, 4 /) )
    real ( kind = 8 ), parameter, dimension ( 4 ) :: denom = (/ &
        4.0D+00, 96.0D+00, 384.0D+00, 92160.0D+00 /)
    real ( kind = 8 ) denpow
    real ( kind = 8 ) eval_pol
    real ( kind = 8 ) df
    real ( kind = 8 ) dinvnr
    real ( kind = 8 ) dt1
    integer ( kind = 4 ) i
    integer ( kind = 4 ), parameter, dimension ( 4 ) :: ideg = (/ 1, 2, 3, 4 /)
    real ( kind = 8 ) p
    real ( kind = 8 ) q
    real ( kind = 8 ) sum1
    real ( kind = 8 ) term
    real ( kind = 8 ) x
    real ( kind = 8 ) xp
    real ( kind = 8 ) xx

    x = abs ( dinvnr ( p, q ) )
    xx = x * x

    sum1 = x
    denpow = 1.0D+00
    do i = 1, 4
        term = eval_pol ( coef(0,i), ideg(i), xx ) * x
        denpow = denpow * df
        sum1 = sum1 + term / ( denpow * denom(i) )
    end do

    if ( 0.5D+00 <= p ) then
        xp = sum1
    else
        xp = -sum1
    end if

    dt1 = xp

    return
    end
    subroutine dzror ( status, x, fx, xlo, xhi, qleft, qhi )

    !*****************************************************************************80
    !
    !! DZROR seeks a zero of a function, using reverse communication.
    !
    !  Discussion:
    !
    !    This routine performs the zero finding.  STZROR must have been called
    !    before this routine in order to set its parameters.
    !
    !  Modified:
    !
    !    09 June 2004
    !
    !  Reference:
    !
    !    JCP Bus, TJ Dekker,
    !    Two Efficient Algorithms with Guaranteed Convergence for
    !    Finding a Zero of a Function,
    !    ACM Transactions on Mathematical Software,
    !    Volume 1, Number 4, pages 330-345, 1975.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) STATUS.  At the beginning of a zero
    !    finding problem, STATUS should be set to 0 and ZROR invoked.  The value
    !    of other parameters will be ignored on this call.
    !    When ZROR needs the function evaluated, it will set
    !    STATUS to 1 and return.  The value of the function
    !    should be set in FX and ZROR again called without
    !    changing any of its other parameters.
    !    When ZROR has finished without error, it will return
    !    with STATUS 0.  In that case (XLO,XHI) bound the answe
    !    If ZROR finds an error (which implies that F(XLO)-Y an
    !    F(XHI)-Y have the same sign, it returns STATUS -1.  In
    !    this case, XLO and XHI are undefined.
    !
    !    Output, real ( kind = 8 ) X, the value of X at which F(X) is to
    !    be evaluated.
    !
    !    Input, real ( kind = 8 ) FX, the value of F(X), which must be calculated
    !    by the user when ZROR has returned on the previous call with STATUS = 1.
    !
    !    Output, real ( kind = 8 ) XLO, XHI, are lower and upper bounds for the
    !    solution when ZROR returns with STATUS = 0.
    !
    !    Output, logical QLEFT,is TRUE if the stepping search terminated
    !    unsucessfully at XLO.  If it is FALSE, the search terminated
    !    unsucessfully at XHI.
    !
    !    Output, logical QHI, is TRUE if Y < F(X) at the termination of the
    !    search and FALSE if F(X) < Y at the termination of the search.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) abstol
    real ( kind = 8 ) b
    real ( kind = 8 ) c
    real ( kind = 8 ) d
    integer ( kind = 4 ) ext
    real ( kind = 8 ) fa
    real ( kind = 8 ) fb
    real ( kind = 8 ) fc
    real ( kind = 8 ) fd
    real ( kind = 8 ) fda
    real ( kind = 8 ) fdb
    logical first
    real ( kind = 8 ) ftol
    real ( kind = 8 ) fx
    integer ( kind = 4 ) i99999
    real ( kind = 8 ) m
    real ( kind = 8 ) mb
    real ( kind = 8 ) p
    real ( kind = 8 ) q
    logical qhi
    logical qleft
    logical qrzero
    real ( kind = 8 ) reltol
    integer ( kind = 4 ) status
    real ( kind = 8 ) tol
    real ( kind = 8 ) w
    real ( kind = 8 ) x
    real ( kind = 8 ) xhi
    real ( kind = 8 ) xlo
    real ( kind = 8 ) :: xxhi = 0.0D+00
    real ( kind = 8 ) :: xxlo = 0.0D+00
    real ( kind = 8 ) zabstl
    real ( kind = 8 ) zreltl
    real ( kind = 8 ) zx
    real ( kind = 8 ) zxhi
    real ( kind = 8 ) zxlo

    save

    ftol(zx) = 0.5D+00 * max ( abstol, reltol * abs ( zx ) )

    if ( 0 < status ) then
        go to 280
    end if

    xlo = xxlo
    xhi = xxhi
    b = xlo
    x = xlo
    !
    !     GET-function-VALUE
    !
    assign 10 to i99999
    go to 270

10  continue

    fb = fx
    xlo = xhi
    a = xlo
    x = xlo
    !
    !     GET-function-VALUE
    !
    assign 20 to i99999
    go to 270
    !
    !  Check that F(ZXLO) < 0 < F(ZXHI)  or F(ZXLO) > 0 > F(ZXHI)
    !
20  continue

    if ( fb < 0.0D+00 ) then
        if ( fx < 0.0D+00 ) then
            status = -1
            qleft = ( fx < fb )
            qhi = .false.
            return
        end if
    end if

    if ( 0.0D+00 < fb ) then
        if ( 0.0D+00 < fx ) then
            status = -1
            qleft = ( fb < fx )
            qhi = .true.
            return
        end if
    end if

    fa = fx
    first = .true.

70  continue

    c = a
    fc = fa
    ext = 0

80  continue

    if ( abs ( fc ) < abs ( fb ) ) then

        if ( c == a ) then
            d = a
            fd = fa
        end if

        a = b
        fa = fb
        xlo = c
        b = xlo
        fb = fc
        c = a
        fc = fa

    end if

    tol = ftol ( xlo )
    m = ( c + b ) * 0.5D+00
    mb = m - b

    if (.not. ( tol < abs ( mb ) ) ) then
        go to 240
    end if

    if ( 3 < ext ) then
        w = mb
        go to 190
    end if

110 continue

    tol = sign ( tol, mb )
    p = ( b - a ) * fb
    !
    !  I had to insert a rudimentary check on the divisions here
    !  to avoid ninny errors, JVB, 09 June 2004.
    !
    if ( first ) then

        q = fa - fb
        first = .false.

    else

        if ( d == b ) then
            fdb = 1.0D+00
        else
            fdb = ( fd - fb ) / ( d - b )
        end if

        if ( d == a ) then
            fda = 1.0D+00
        else
            fda = ( fd - fa ) / ( d - a )
        end if

        p = fda * p
        q = fdb * fa - fda * fb

    end if

130 continue

    if ( p < 0.0D+00 ) then
        p = -p
        q = -q
    end if

140 continue

    if ( ext == 3 ) then
        p = p *  2.0D+00
    end if

    if (.not. ( ( p * 1.0D+00 ) == 0.0D+00 .or. p <= ( q * tol ) ) ) then
        go to 150
    end if

    w = tol
    go to 180

150 continue

    if ( p < mb * q ) then
        w = p / q
    else
        w = mb
    end if

180 continue
190 continue

    d = a
    fd = fa
    a = b
    fa = fb
    b = b + w
    xlo = b
    x = xlo
    !
    !  GET-function-VALUE
    !
    assign 200 to i99999
    go to 270

200 continue

    fb = fx

    if ( 0.0D+00 <= fc * fb ) then

        go to 70

    else

        if ( w == mb ) then
            ext = 0
        else
            ext = ext + 1
        end if

        go to 80

    end if

240 continue

    xhi = c
    qrzero = ( 0.0D+00 <= fc .and. fb <= 0.0D+00 ) .or. &
        ( fc < 0.0D+00 .and. fb >= 0.0D+00 )

    if ( qrzero ) then
        status = 0
    else
        status = -1
    end if

    return

    entry dstzr ( zxlo, zxhi, zabstl, zreltl )

    !*****************************************************************************80
    !
    !! DSTZR - SeT ZeRo finder - Reverse communication version
    !
    !  Discussion:
    !
    !    This routine sets quantities needed by ZROR.  The function of ZROR
    !    and the quantities set is given here.
    !
    !    Given a function F, find XLO such that F(XLO) = 0.
    !
    !     Input condition. F is a real ( kind = 8 ) function of a single
    !     real ( kind = 8 ) argument and XLO and XHI are such that
    !          F(XLO)*F(XHI)  <=  0.0
    !
    !     If the input condition is met, QRZERO returns .TRUE.
    !     and output values of XLO and XHI satisfy the following
    !          F(XLO)*F(XHI)  <= 0.
    !          ABS ( F(XLO) ) <= ABS ( F(XHI) )
    !          ABS ( XLO - XHI ) <= TOL(X)
    !     where
    !          TOL(X) = MAX ( ABSTOL, RELTOL * ABS ( X ) )
    !
    !     If this algorithm does not find XLO and XHI satisfying
    !     these conditions then QRZERO returns .FALSE.  This
    !     implies that the input condition was not met.
    !
    !  Reference:
    !
    !    JCP Bus, TJ Dekker,
    !    Two Efficient Algorithms with Guaranteed Convergence for
    !    Finding a Zero of a Function,
    !    ACM Transactions on Mathematical Software,
    !    Volume 1, Number 4, pages 330-345, 1975.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) XLO, XHI, the left and right endpoints of the
    !    interval to be searched for a solution.
    !
    !    Input, real ( kind = 8 ) ABSTOL, RELTOL, two numbers that determine
    !    the accuracy of the solution.
    !
    xxlo = zxlo
    xxhi = zxhi
    abstol = zabstl
    reltol = zreltl
    return
    !
    !     TO GET-function-VALUE
    !
270 status = 1
    return

280 continue
    go to i99999

    end
    subroutine erf_values ( n_data, x, fx )

    !*****************************************************************************80
    !
    !! ERF_VALUES returns some values of the ERF or "error" function.
    !
    !  Discussion:
    !
    !    ERF(X) = ( 2 / sqrt ( PI ) * integral ( 0 <= T <= X ) exp ( - T^2 ) dT
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    17 April 2001
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions,
    !    US Department of Commerce, 1964.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) N_DATA.  The user sets N_DATA to 0
    !    before the first call.  On each call, the routine increments N_DATA by 1,
    !    and returns the corresponding data; when there is no more data, the
    !    output value of N_DATA will be 0 again.
    !
    !    Output, real ( kind = 8 ) X, the argument of the function.
    !
    !    Output, real ( kind = 8 ) FX, the value of the function.
    !
    implicit none

    integer ( kind = 4 ), parameter :: n_max = 21

    real ( kind = 8 ) fx
    real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ &
        0.0000000000D+00, 0.1124629160D+00, 0.2227025892D+00, 0.3286267595D+00, &
        0.4283923550D+00, 0.5204998778D+00, 0.6038560908D+00, 0.6778011938D+00, &
        0.7421009647D+00, 0.7969082124D+00, 0.8427007929D+00, 0.8802050696D+00, &
        0.9103139782D+00, 0.9340079449D+00, 0.9522851198D+00, 0.9661051465D+00, &
        0.9763483833D+00, 0.9837904586D+00, 0.9890905016D+00, 0.9927904292D+00, &
        0.9953222650D+00 /)
    integer ( kind = 4 ) n_data
    real ( kind = 8 ) x
    real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ &
        0.0D+00, 0.1D+00, 0.2D+00, 0.3D+00, &
        0.4D+00, 0.5D+00, 0.6D+00, 0.7D+00, &
        0.8D+00, 0.9D+00, 1.0D+00, 1.1D+00, &
        1.2D+00, 1.3D+00, 1.4D+00, 1.5D+00, &
        1.6D+00, 1.7D+00, 1.8D+00, 1.9D+00, &
        2.0D+00 /)

    if ( n_data < 0 ) then
        n_data = 0
    end if

    n_data = n_data + 1

    if ( n_max < n_data ) then
        n_data = 0
        x = 0.0D+00
        fx = 0.0D+00
    else
        x = x_vec(n_data)
        fx = fx_vec(n_data)
    end if

    return
    end
    function error_f ( x )

    !*****************************************************************************80
    !
    !! ERROR_F evaluates the error function.
    !
    !  Discussion:
    !
    !    Since some compilers already supply a routine named ERF which evaluates
    !    the error function, this routine has been given a distinct, if
    !    somewhat unnatural, name.
    !
    !    The function is defined by:
    !
    !      ERF(X) = ( 2 / sqrt ( PI ) )
    !        * Integral ( 0 <= T <= X ) EXP ( - T**2 ) dT.
    !
    !    Properties of the function include:
    !
    !      Limit ( X -> -Infinity ) ERF(X) =          -1.0;
    !                               ERF(0) =           0.0;
    !                               ERF(0.476936...) = 0.5;
    !      Limit ( X -> +Infinity ) ERF(X) =          +1.0.
    !
    !      0.5D+00 * ( ERF(X/sqrt(2)) + 1 ) = Normal_01_CDF(X)
    !
    !  Modified:
    !
    !    17 November 2006
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) X, the argument.
    !
    !    Output, real ( kind = 8 ) ERF, the value of the error function at X.
    !
    implicit none

    real ( kind = 8 ), parameter, dimension ( 5 ) :: a = (/ &
        0.771058495001320D-04, &
        -0.133733772997339D-02, &
        0.323076579225834D-01, &
        0.479137145607681D-01, &
        0.128379167095513D+00 /)
    real ( kind = 8 ) ax
    real ( kind = 8 ), parameter, dimension ( 3 ) :: b = (/ &
        0.301048631703895D-02, &
        0.538971687740286D-01, &
        0.375795757275549D+00 /)
    real ( kind = 8 ) bot
    real ( kind = 8 ), parameter :: c = 0.564189583547756D+00
    real ( kind = 8 ) error_f
    real ( kind = 8 ), dimension ( 8 ) :: p = (/   &
        -1.36864857382717D-07, 5.64195517478974D-01, &
        7.21175825088309D+00, 4.31622272220567D+01, &
        1.52989285046940D+02, 3.39320816734344D+02, &
        4.51918953711873D+02, 3.00459261020162D+02 /)
    real ( kind = 8 ), dimension ( 8 ) :: q = (/ &
        1.00000000000000D+00, 1.27827273196294D+01, &
        7.70001529352295D+01, 2.77585444743988D+02, &
        6.38980264465631D+02, 9.31354094850610D+02, &
        7.90950925327898D+02, 3.00459260956983D+02 /)
    real ( kind = 8 ), dimension ( 5 ) :: r = (/ &
        2.10144126479064D+00, 2.62370141675169D+01, &
        2.13688200555087D+01, 4.65807828718470D+00, &
        2.82094791773523D-01 /)
    real ( kind = 8 ), parameter, dimension ( 4 ) :: s = (/ &
        9.41537750555460D+01, 1.87114811799590D+02, &
        9.90191814623914D+01, 1.80124575948747D+02 /)
    real ( kind = 8 ) t
    real ( kind = 8 ) top
    real ( kind = 8 ) x
    real ( kind = 8 ) x2

    ax = abs ( x )

    if ( ax <= 0.5D+00 ) then

        t = x * x

        top = (((( a(1)   * t &
            + a(2) ) * t &
            + a(3) ) * t &
            + a(4) ) * t &
            + a(5) ) + 1.0D+00

        bot = (( b(1) * t + b(2) ) * t + b(3) ) * t + 1.0D+00
        error_f = ax * ( top / bot )

    else if ( ax <= 4.0D+00 ) then

        top = (((((( p(1)   * ax &
            + p(2) ) * ax &
            + p(3) ) * ax &
            + p(4) ) * ax &
            + p(5) ) * ax &
            + p(6) ) * ax &
            + p(7) ) * ax &
            + p(8)

        bot = (((((( q(1) * ax + q(2) ) * ax + q(3) ) * ax + q(4) ) * ax &
            + q(5) ) * ax + q(6) ) * ax + q(7) ) * ax + q(8)

        error_f = 0.5D+00 &
            + ( 0.5D+00 - exp ( - x * x ) * top / bot )

    else if ( ax < 5.8D+00 ) then

        x2 = x * x
        t = 1.0D+00 / x2

        top = ((( r(1) * t + r(2) ) * t + r(3) ) * t + r(4) ) * t + r(5)

        bot = ((( s(1) * t + s(2) ) * t + s(3) ) * t + s(4) ) * t &
            + 1.0D+00

        error_f = ( c - top / ( x2 * bot )) / ax
        error_f = 0.5D+00 &
            + ( 0.5D+00 - exp ( - x2 ) * error_f )

    else

        error_f = 1.0D+00

    end if

    if ( x < 0.0D+00 ) then
        error_f = -error_f
    end if

    return
    end
    function error_fc ( ind, x )

    !*****************************************************************************80
    !
    !! ERROR_FC evaluates the complementary error function.
    !
    !  Modified:
    !
    !    09 December 1999
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) IND, chooses the scaling.
    !    If IND is nonzero, then the value returned has been multiplied by
    !    EXP(X*X).
    !
    !    Input, real ( kind = 8 ) X, the argument of the function.
    !
    !    Output, real ( kind = 8 ) ERROR_FC, the value of the complementary
    !    error function.
    !
    implicit none

    real ( kind = 8 ), dimension ( 5 ) :: a = (/ &
        0.771058495001320D-04,  -0.133733772997339D-02, &
        0.323076579225834D-01,   0.479137145607681D-01, &
        0.128379167095513D+00 /)
    real ( kind = 8 ) ax
    real ( kind = 8 ), dimension(3) :: b = (/ &
        0.301048631703895D-02, &
        0.538971687740286D-01, &
        0.375795757275549D+00 /)
    real ( kind = 8 ) bot
    real ( kind = 8 ), parameter :: c = 0.564189583547756D+00
    real ( kind = 8 ) e
    real ( kind = 8 ) error_fc
    real ( kind = 8 ) exparg
    integer ( kind = 4 ) ind
    real ( kind = 8 ), dimension ( 8 ) :: p = (/ &
        -1.36864857382717D-07, 5.64195517478974D-01, &
        7.21175825088309D+00, 4.31622272220567D+01, &
        1.52989285046940D+02, 3.39320816734344D+02, &
        4.51918953711873D+02, 3.00459261020162D+02 /)
    real ( kind = 8 ), dimension ( 8 ) :: q = (/  &
        1.00000000000000D+00, 1.27827273196294D+01, &
        7.70001529352295D+01, 2.77585444743988D+02, &
        6.38980264465631D+02, 9.31354094850610D+02, &
        7.90950925327898D+02, 3.00459260956983D+02 /)
    real ( kind = 8 ), dimension ( 5 ) :: r = (/ &
        2.10144126479064D+00, 2.62370141675169D+01, &
        2.13688200555087D+01, 4.65807828718470D+00, &
        2.82094791773523D-01 /)
    real ( kind = 8 ), dimension ( 4 ) :: s = (/ &
        9.41537750555460D+01, 1.87114811799590D+02, &
        9.90191814623914D+01, 1.80124575948747D+02 /)
    real ( kind = 8 ) t
    real ( kind = 8 ) top
    real ( kind = 8 ) w
    real ( kind = 8 ) x
    !
    !  ABS ( X ) <= 0.5
    !
    ax = abs ( x )

    if ( ax <= 0.5D+00 ) then

        t = x * x

        top = (((( a(1) * t + a(2) ) * t + a(3) ) * t + a(4) ) * t + a(5) ) &
            + 1.0D+00

        bot = (( b(1) * t + b(2) ) * t + b(3) ) * t + 1.0D+00

        error_fc = 0.5D+00 + ( 0.5D+00 &
            - x * ( top / bot ) )

        if ( ind /= 0 ) then
            error_fc = exp ( t ) * error_fc
        end if

        return

    end if
    !
    !  0.5 < abs ( X ) <= 4
    !
    if ( ax <= 4.0D+00 ) then

        top = (((((( p(1) * ax + p(2)) * ax + p(3)) * ax + p(4)) * ax &
            + p(5)) * ax + p(6)) * ax + p(7)) * ax + p(8)

        bot = (((((( q(1) * ax + q(2)) * ax + q(3)) * ax + q(4)) * ax &
            + q(5)) * ax + q(6)) * ax + q(7)) * ax + q(8)

        error_fc = top / bot
        !
        !  4 < ABS ( X )
        !
    else

        if ( x <= -5.6D+00 ) then

            if ( ind == 0 ) then
                error_fc =  2.0D+00
            else
                error_fc =  2.0D+00  * exp ( x * x )
            end if

            return

        end if

        if ( ind == 0 ) then

            if ( 100.0D+00 < x ) then
                error_fc = 0.0D+00
                return
            end if

            if ( -exparg ( 1 ) < x * x ) then
                error_fc = 0.0D+00
                return
            end if

        end if

        t = ( 1.0D+00 / x )**2

        top = ((( r(1) * t + r(2) ) * t + r(3) ) * t + r(4) ) * t + r(5)

        bot = ((( s(1) * t + s(2) ) * t + s(3) ) * t + s(4) ) * t &
            + 1.0D+00

        error_fc = ( c - t * top / bot ) / ax

    end if
    !
    !  Final assembly.
    !
    if ( ind /= 0 ) then

        if ( x < 0.0D+00 ) then
            error_fc =  2.0D+00  * exp ( x * x ) - error_fc
        end if

    else

        w = x * x
        t = w
        e = w - t
        error_fc = (( 0.5D+00 &
            + ( 0.5D+00 - e ) ) * exp ( - t ) ) * error_fc

        if ( x < 0.0D+00 ) then
            error_fc =  2.0D+00  - error_fc
        end if

    end if

    return
    end
    function esum ( mu, x )

    !*****************************************************************************80
    !
    !! ESUM evaluates exp ( MU + X ).
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) MU, part of the argument.
    !
    !    Input, real ( kind = 8 ) X, part of the argument.
    !
    !    Output, real ( kind = 8 ) ESUM, the value of exp ( MU + X ).
    !
    implicit none

    real ( kind = 8 ) esum
    integer ( kind = 4 ) mu
    real ( kind = 8 ) w
    real ( kind = 8 ) x

    if ( x <= 0.0D+00 ) then
        if ( 0 <= mu ) then
            w = mu + x
            if ( w <= 0.0D+00 ) then
                esum = exp ( w )
                return
            end if
        end if
    else if ( 0.0D+00 < x ) then
        if ( mu <= 0 ) then
            w = mu + x
            if ( 0.0D+00 <= w ) then
                esum = exp ( w )
                return
            end if
        end if
    end if

    w = mu
    esum = exp ( w ) * exp ( x )

    return
    end
    function eval_pol ( a, n, x )

    !*****************************************************************************80
    !
    !! EVAL_POL evaluates a polynomial at X.
    !
    !  Discussion:
    !
    !    EVAL_POL = A(0) + A(1)*X + ... + A(N)*X**N
    !
    !  Modified:
    !
    !    15 December 1999
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A(0:N), coefficients of the polynomial.
    !
    !    Input, integer ( kind = 4 ) N, length of A.
    !
    !    Input, real ( kind = 8 ) X, the point at which the polynomial
    !    is to be evaluated.
    !
    !    Output, real ( kind = 8 ) EVAL_POL, the value of the polynomial at X.
    !
    implicit none

    integer ( kind = 4 ) n

    real ( kind = 8 ) a(0:n)
    real ( kind = 8 ) eval_pol
    integer ( kind = 4 ) i
    real ( kind = 8 ) term
    real ( kind = 8 ) x

    term = a(n)
    do i = n - 1, 0, -1
        term = term * x + a(i)
    end do

    eval_pol = term

    return
    end
    function exparg ( l )

    !*****************************************************************************80
    !
    !! EXPARG returns the largest or smallest legal argument for EXP.
    !
    !  Discussion:
    !
    !    Only an approximate limit for the argument of EXP is desired.
    !
    !  Modified:
    !
    !    09 December 1999
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) L, indicates which limit is desired.
    !    If L = 0, then the largest positive argument for EXP is desired.
    !    Otherwise, the largest negative argument for EXP for which the
    !    result is nonzero is desired.
    !
    !    Output, real ( kind = 8 ) EXPARG, the desired value.
    !
    implicit none

    integer ( kind = 4 ) b
    real ( kind = 8 ) exparg
    integer ( kind = 4 ) ipmpar
    integer ( kind = 4 ) l
    real ( kind = 8 ) lnb
    integer ( kind = 4 ) m
    !
    !  Get the arithmetic base.
    !
    b = ipmpar(4)
    !
    !  Compute the logarithm of the arithmetic base.
    !
    if ( b == 2 ) then
        lnb = 0.69314718055995D+00
    else if ( b == 8 ) then
        lnb = 2.0794415416798D+00
    else if ( b == 16 ) then
        lnb = 2.7725887222398D+00
    else
        lnb = log ( real ( b, kind = 8 ) )
    end if

    if ( l /= 0 ) then
        m = ipmpar(9) - 1
        exparg = 0.99999D+00 * ( m * lnb )
    else
        m = ipmpar(10)
        exparg = 0.99999D+00 * ( m * lnb )
    end if

    return
    end
    subroutine f_cdf_values ( n_data, a, b, x, fx )

    !*****************************************************************************80
    !
    !! F_CDF_VALUES returns some values of the F CDF test function.
    !
    !  Discussion:
    !
    !    The value of F_CDF ( DFN, DFD, X ) can be evaluated in Mathematica by
    !    commands like:
    !
    !      Needs["Statistics`ContinuousDistributions`"]
    !      CDF[FRatioDistribution[ DFN, DFD ], X ]
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    11 June 2004
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions,
    !    US Department of Commerce, 1964.
    !
    !    Stephen Wolfram,
    !    The Mathematica Book,
    !    Fourth Edition,
    !    Wolfram Media / Cambridge University Press, 1999.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) N_DATA.  The user sets N_DATA to 0
    !    before the first call.  On each call, the routine increments N_DATA by 1,
    !    and returns the corresponding data; when there is no more data, the
    !    output value of N_DATA will be 0 again.
    !
    !    Output, integer ( kind = 4 ) A, integer B, real ( kind = 8 ) X, the
    !    arguments of the function.
    !
    !    Output, real ( kind = 8 ) FX, the value of the function.
    !
    implicit none

    integer ( kind = 4 ), parameter :: n_max = 20

    integer ( kind = 4 ) a
    integer ( kind = 4 ), save, dimension ( n_max ) :: a_vec = (/ &
        1, 1, 5, 1, &
        2, 4, 1, 6, &
        8, 1, 3, 6, &
        1, 1, 1, 1, &
        2, 3, 4, 5 /)
    integer ( kind = 4 ) b
    integer ( kind = 4 ), save, dimension ( n_max ) :: b_vec = (/ &
        1,  5,  1,  5, &
        10, 20,  5,  6, &
        16,  5, 10, 12, &
        5,  5,  5,  5, &
        5,  5,  5,  5 /)
    real ( kind = 8 ) fx
    real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ &
        0.500000D+00, 0.499971D+00, 0.499603D+00, 0.749699D+00, &
        0.750466D+00, 0.751416D+00, 0.899987D+00, 0.899713D+00, &
        0.900285D+00, 0.950025D+00, 0.950057D+00, 0.950193D+00, &
        0.975013D+00, 0.990002D+00, 0.994998D+00, 0.999000D+00, &
        0.568799D+00, 0.535145D+00, 0.514343D+00, 0.500000D+00 /)
    integer ( kind = 4 ) n_data
    real ( kind = 8 ) x
    real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ &
        1.00D+00,  0.528D+00, 1.89D+00,  1.69D+00, &
        1.60D+00,  1.47D+00,  4.06D+00,  3.05D+00, &
        2.09D+00,  6.61D+00,  3.71D+00,  3.00D+00, &
        10.01D+00, 16.26D+00, 22.78D+00, 47.18D+00, &
        1.00D+00,  1.00D+00,  1.00D+00,  1.00D+00 /)

    if ( n_data < 0 ) then
        n_data = 0
    end if

    n_data = n_data + 1

    if ( n_max < n_data ) then
        n_data = 0
        a = 0
        b = 0
        x = 0.0D+00
        fx = 0.0D+00
    else
        a = a_vec(n_data)
        b = b_vec(n_data)
        x = x_vec(n_data)
        fx = fx_vec(n_data)
    end if

    return
    end
    subroutine f_noncentral_cdf_values ( n_data, a, b, lambda, x, fx )

    !*****************************************************************************80
    !
    !! F_NONCENTRAL_CDF_VALUES returns some values of the F CDF test function.
    !
    !  Discussion:
    !
    !    The value of NONCENTRAL_F_CDF ( DFN, DFD, LAMDA, X ) can be evaluated
    !    in Mathematica by commands like:
    !
    !      Needs["Statistics`ContinuousDistributions`"]
    !      CDF[NoncentralFRatioDistribution[ DFN, DFD, LAMBDA ], X ]
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    12 June 2004
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions,
    !    US Department of Commerce, 1964.
    !
    !    Stephen Wolfram,
    !    The Mathematica Book,
    !    Fourth Edition,
    !    Wolfram Media / Cambridge University Press, 1999.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) N_DATA.  The user sets N_DATA to 0
    !    before the first call.  On each call, the routine increments N_DATA by 1,
    !    and returns the corresponding data; when there is no more data, the
    !    output value of N_DATA will be 0 again.
    !
    !    Output, integer ( kind = 4 ) A, B, real ( kind = 8 ) LAMBDA, the
    !    parameters of the function.
    !
    !    Output, real ( kind = 8 ) X, the argument of the function.
    !
    !    Output, real ( kind = 8 ) FX, the value of the function.
    !
    implicit none

    integer ( kind = 4 ), parameter :: n_max = 22

    integer ( kind = 4 ) a
    integer ( kind = 4 ), save, dimension ( n_max ) :: a_vec = (/ &
        1,  1,  1,  1, &
        1,  1,  1,  1, &
        1,  1,  2,  2, &
        3,  3,  4,  4, &
        5,  5,  6,  6, &
        8, 16 /)
    integer ( kind = 4 ) b
    integer ( kind = 4 ), save, dimension ( n_max ) :: b_vec = (/ &
        1,  5,  5,  5, &
        5,  5,  5,  5, &
        5,  5,  5, 10, &
        5,  5,  5,  5, &
        1,  5,  6, 12, &
        16,  8 /)
    real ( kind = 8 ) fx
    real, save, dimension ( n_max ) :: fx_vec = (/ &
        0.500000D+00, 0.636783D+00, 0.584092D+00, 0.323443D+00, &
        0.450119D+00, 0.607888D+00, 0.705928D+00, 0.772178D+00, &
        0.819105D+00, 0.317035D+00, 0.432722D+00, 0.450270D+00, &
        0.426188D+00, 0.337744D+00, 0.422911D+00, 0.692767D+00, &
        0.363217D+00, 0.421005D+00, 0.426667D+00, 0.446402D+00, &
        0.844589D+00, 0.816368D+00 /)
    real ( kind = 8 ) lambda
    real, save, dimension ( n_max ) :: lambda_vec = (/ &
        0.00D+00,  0.000D+00, 0.25D+00,  1.00D+00, &
        1.00D+00,  1.00D+00,  1.00D+00,  1.00D+00, &
        1.00D+00,  2.00D+00,  1.00D+00,  1.00D+00, &
        1.00D+00,  2.00D+00,  1.00D+00,  1.00D+00, &
        0.00D+00,  1.00D+00,  1.00D+00,  1.00D+00, &
        1.00D+00,  1.00D+00 /)
    integer ( kind = 4 ) n_data
    real ( kind = 8 ) x
    real, save, dimension ( n_max ) :: x_vec = (/ &
        1.00D+00,  1.00D+00, 1.00D+00,  0.50D+00, &
        1.00D+00,  2.00D+00, 3.00D+00,  4.00D+00, &
        5.00D+00,  1.00D+00, 1.00D+00,  1.00D+00, &
        1.00D+00,  1.00D+00, 1.00D+00,  2.00D+00, &
        1.00D+00,  1.00D+00, 1.00D+00,  1.00D+00, &
        2.00D+00,  2.00D+00 /)

    if ( n_data < 0 ) then
        n_data = 0
    end if

    n_data = n_data + 1

    if ( n_max < n_data ) then
        n_data = 0
        a = 0
        b = 0
        lambda = 0.0D+00
        x = 0.0D+00
        fx = 0.0D+00
    else
        a = a_vec(n_data)
        b = b_vec(n_data)
        lambda = lambda_vec(n_data)
        x = x_vec(n_data)
        fx = fx_vec(n_data)
    end if

    return
    end
    function fpser ( a, b, x, eps )

    !*****************************************************************************80
    !
    !! FPSER evaluates IX(A,B)(X) for very small B.
    !
    !  Discussion:
    !
    !    This routine is appropriate for use when
    !
    !      B < min ( EPS, EPS * A )
    !
    !    and
    !
    !      X <= 0.5.
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, B, parameters of the function.
    !
    !    Input, real ( kind = 8 ) X, the point at which the function is to
    !    be evaluated.
    !
    !    Input, real ( kind = 8 ) EPS, a tolerance.
    !
    !    Output, real ( kind = 8 ) FPSER, the value of IX(A,B)(X).
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) an
    real ( kind = 8 ) b
    real ( kind = 8 ) c
    real ( kind = 8 ) eps
    real ( kind = 8 ) exparg
    real ( kind = 8 ) fpser
    real ( kind = 8 ) s
    real ( kind = 8 ) t
    real ( kind = 8 ) tol
    real ( kind = 8 ) x

    fpser = 1.0D+00

    if ( 1.0D-03 * eps < a ) then
        fpser = 0.0D+00
        t = a * log ( x )
        if ( t < exparg ( 1 ) ) then
            return
        end if
        fpser = exp ( t )
    end if
    !
    !  1/B(A,B) = B
    !
    fpser = ( b / a ) * fpser
    tol = eps / a
    an = a + 1.0D+00
    t = x
    s = t / an

    do

        an = an + 1.0D+00
        t = x * t
        c = t / an
        s = s + c

        if ( abs ( c ) <= tol ) then
            exit
        end if

    end do

    fpser = fpser * ( 1.0D+00 + a * s )

    return
    end
    function gam1 ( a )

    !*****************************************************************************80
    !
    !! GAM1 computes 1 / GAMMA(A+1) - 1 for -0.5 <= A <= 1.5
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, forms the argument of the Gamma function.
    !
    !    Output, real ( kind = 8 ) GAM1, the value of 1 / GAMMA ( A + 1 ) - 1.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) bot
    real ( kind = 8 ) d
    real ( kind = 8 ) gam1
    real ( kind = 8 ), parameter, dimension ( 7 ) :: p = (/ &
        0.577215664901533D+00, -0.409078193005776D+00, &
        -0.230975380857675D+00,  0.597275330452234D-01, &
        0.766968181649490D-02, -0.514889771323592D-02, &
        0.589597428611429D-03 /)
    real ( kind = 8 ), dimension ( 5 ) :: q = (/ &
        0.100000000000000D+01, 0.427569613095214D+00, &
        0.158451672430138D+00, 0.261132021441447D-01, &
        0.423244297896961D-02 /)
    real ( kind = 8 ), dimension ( 9 ) :: r = (/ &
        -0.422784335098468D+00, -0.771330383816272D+00, &
        -0.244757765222226D+00,  0.118378989872749D+00, &
        0.930357293360349D-03, -0.118290993445146D-01, &
        0.223047661158249D-02,  0.266505979058923D-03, &
        -0.132674909766242D-03 /)
    real ( kind = 8 ), parameter :: s1 = 0.273076135303957D+00
    real ( kind = 8 ), parameter :: s2 = 0.559398236957378D-01
    real ( kind = 8 ) t
    real ( kind = 8 ) top
    real ( kind = 8 ) w

    d = a - 0.5D+00

    if ( 0.0D+00 < d ) then
        t = d - 0.5D+00
    else
        t = a
    end if

    if ( t == 0.0D+00 ) then

        gam1 = 0.0D+00

    else if ( 0.0D+00 < t ) then

        top = (((((    &
            p(7)   &
            * t + p(6) ) &
            * t + p(5) ) &
            * t + p(4) ) &
            * t + p(3) ) &
            * t + p(2) ) &
            * t + p(1)

        bot = ((( q(5) * t + q(4) ) * t + q(3) ) * t + q(2) ) * t &
            + 1.0D+00

        w = top / bot

        if ( d <= 0.0D+00 ) then
            gam1 = a * w
        else
            gam1 = ( t / a ) * ( ( w - 0.5D+00 ) &
                - 0.5D+00 )
        end if

    else if ( t < 0.0D+00 ) then

        top = (((((((  &
            r(9)   &
            * t + r(8) ) &
            * t + r(7) ) &
            * t + r(6) ) &
            * t + r(5) ) &
            * t + r(4) ) &
            * t + r(3) ) &
            * t + r(2) ) &
            * t + r(1)

        bot = ( s2 * t + s1 ) * t + 1.0D+00
        w = top / bot

        if ( d <= 0.0D+00 ) then
            gam1 = a * ( ( w + 0.5D+00 ) + 0.5D+00 )
        else
            gam1 = t * w / a
        end if

    end if

    return
    end
    function gamma ( a )

    !*****************************************************************************80
    !
    !! GAMMA evaluates the gamma function.
    !
    !  Author:
    !
    !    Alfred Morris,
    !    Naval Surface Weapons Center,
    !    Dahlgren, Virginia.
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, the argument of the Gamma function.
    !
    !    Output, real ( kind = 8 ) GAMMA, the value of the Gamma function.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) bot
    real ( kind = 8 ), parameter :: d = 0.41893853320467274178D+00
    real ( kind = 8 ) exparg
    real ( kind = 8 ) g
    real ( kind = 8 ) gamma
    integer ( kind = 4 ) i
    integer ( kind = 4 ) j
    real ( kind = 8 ) lnx
    integer ( kind = 4 ) m
    integer ( kind = 4 ) n
    real ( kind = 8 ), dimension ( 7 ) :: p = (/ &
        0.539637273585445D-03, 0.261939260042690D-02, &
        0.204493667594920D-01, 0.730981088720487D-01, &
        0.279648642639792D+00, 0.553413866010467D+00, &
        1.0D+00 /)
    real ( kind = 8 ), parameter :: pi = 3.1415926535898D+00
    real ( kind = 8 ), dimension ( 7 ) :: q = (/ &
        -0.832979206704073D-03,  0.470059485860584D-02, &
        0.225211131035340D-01, -0.170458969313360D+00, &
        -0.567902761974940D-01,  0.113062953091122D+01, &
        1.0D+00 /)
    real ( kind = 8 ), parameter :: r1 =  0.820756370353826D-03
    real ( kind = 8 ), parameter :: r2 = -0.595156336428591D-03
    real ( kind = 8 ), parameter :: r3 =  0.793650663183693D-03
    real ( kind = 8 ), parameter :: r4 = -0.277777777770481D-02
    real ( kind = 8 ), parameter :: r5 =  0.833333333333333D-01
    real ( kind = 8 ) s
    real ( kind = 8 ) t
    real ( kind = 8 ) top
    real ( kind = 8 ) w
    real ( kind = 8 ) x
    real ( kind = 8 ) z

    gamma = 0.0D+00
    x = a

    if ( abs ( a ) < 15.0D+00 ) then
        !
        !  Evaluation of GAMMA(A) for |A| < 15
        !
        t = 1.0D+00
        m = int ( a ) - 1
        !
        !  Let T be the product of A-J when 2 <= A.
        !
        if ( 0 <= m ) then

            do j = 1, m
                x = x - 1.0D+00
                t = x * t
            end do

            x = x - 1.0D+00
            !
            !  Let T be the product of A+J WHEN A < 1
            !
        else

            t = a

            if ( a <= 0.0D+00 ) then

                m = - m - 1

                do j = 1, m
                    x = x + 1.0D+00
                    t = x * t
                end do

                x = ( x + 0.5D+00 ) + 0.5D+00
                t = x * t
                if ( t == 0.0D+00 ) then
                    return
                end if

            end if
            !
            !  Check if 1/T can overflow.
            !
            if ( abs ( t ) < 1.0D-30 ) then
                if ( 1.0001D+00 < abs ( t ) * huge ( t ) ) then
                    gamma = 1.0D+00 / t
                end if
                return
            end if

        end if
        !
        !  Compute Gamma(1 + X) for 0 <= X < 1.
        !
        top = p(1)
        bot = q(1)
        do i = 2, 7
            top = top * x + p(i)
            bot = bot * x + q(i)
        end do

        gamma = top / bot
        !
        !  Termination.
        !
        if ( 1.0D+00 <= a ) then
            gamma = gamma * t
        else
            gamma = gamma / t
        end if
        !
        !  Evaluation of Gamma(A) FOR 15 <= ABS ( A ).
        !
    else

        if ( 1000.0D+00 <= abs ( a ) ) then
            return
        end if

        if ( a <= 0.0D+00 ) then

            x = -a
            n = x
            t = x - n

            if ( 0.9D+00 < t ) then
                t = 1.0D+00 - t
            end if

            s = sin ( pi * t ) / pi

            if ( mod ( n, 2 ) == 0 ) then
                s = -s
            end if

            if ( s == 0.0D+00 ) then
                return
            end if

        end if
        !
        !  Compute the modified asymptotic sum.
        !
        t = 1.0D+00 / ( x * x )

        g = (((( r1 * t + r2 ) * t + r3 ) * t + r4 ) * t + r5 ) / x

        lnx = log ( x )
        !
        !  Final assembly.
        !
        z = x
        g = ( d + g ) + ( z - 0.5D+00 ) &
            * ( lnx - 1.0D+00 )
        w = g
        t = g - real ( w, kind = 8 )

        if ( 0.99999D+00 * exparg ( 0 ) < w ) then
            return
        end if

        gamma = exp ( w )* ( 1.0D+00 + t )

        if ( a < 0.0D+00 ) then
            gamma = ( 1.0D+00 / ( gamma * s ) ) / x
        end if

    end if

    return
    end
    subroutine gamma_inc ( a, x, ans, qans, ind )

    !*****************************************************************************80
    !
    !! GAMMA_INC evaluates the incomplete gamma ratio functions P(A,X) and Q(A,X).
    !
    !  Modified:
    !
    !    16 April 2005
    !
    !  Author:
    !
    !    Alfred Morris,
    !    Naval Surface Weapons Center,
    !    Dahlgren, Virginia.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, X, the arguments of the incomplete
    !    gamma ratio.  A and X must be nonnegative.  A and X cannot
    !    both be zero.
    !
    !    Output, real ( kind = 8 ) ANS, QANS.  On normal output,
    !    ANS = P(A,X) and QANS = Q(A,X).  However, ANS is set to 2 if
    !    A or X is negative, or both are 0, or when the answer is
    !    computationally indeterminate because A is extremely large
    !    and X is very close to A.
    !
    !    Input, integer ( kind = 4 ) IND, indicates the accuracy request:
    !    0, as much accuracy as possible.
    !    1, to within 1 unit of the 6-th significant digit,
    !    otherwise, to within 1 unit of the 3rd significant digit.
    !
    !  Local Parameters:
    !
    !     ALOG10 = LN(10)
    !     RT2PIN = 1/SQRT(2*PI)
    !     RTPI   = SQRT(PI)
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) a2n
    real ( kind = 8 ) a2nm1
    real ( kind = 8 ) acc
    real ( kind = 8 ), dimension ( 3 ) :: acc0 = (/ &
        5.0D-15, 5.0D-07, 5.0D-04 /)
    real ( kind = 8 ), parameter :: alog10 = 2.30258509299405D+00
    real ( kind = 8 ) am0
    real ( kind = 8 ) amn
    real ( kind = 8 ) an
    real ( kind = 8 ) an0
    real ( kind = 8 ) ans
    real ( kind = 8 ) apn
    real ( kind = 8 ) b2n
    real ( kind = 8 ) b2nm1
    real ( kind = 8 ) big(3)
    real ( kind = 8 ) c
    real ( kind = 8 ) c0
    real ( kind = 8 ) c1
    real ( kind = 8 ) c2
    real ( kind = 8 ) c3
    real ( kind = 8 ) c4
    real ( kind = 8 ) c5
    real ( kind = 8 ) c6
    real ( kind = 8 ) cma
    real ( kind = 8 ) d0(13)
    real ( kind = 8 ) d1(12)
    real ( kind = 8 ) d2(10)
    real ( kind = 8 ) d3(8)
    real ( kind = 8 ) d4(6)
    real ( kind = 8 ) d5(4)
    real ( kind = 8 ) d6(2)
    real ( kind = 8 ) d10
    real ( kind = 8 ) d20
    real ( kind = 8 ) d30
    real ( kind = 8 ) d40
    real ( kind = 8 ) d50
    real ( kind = 8 ) d60
    real ( kind = 8 ) d70
    real ( kind = 8 ) e
    real ( kind = 8 ) e0
    real ( kind = 8 ) e00(3)
    real ( kind = 8 ) error_f
    real ( kind = 8 ) error_fc
    real ( kind = 8 ) g
    real ( kind = 8 ) gam1
    real ( kind = 8 ) gamma
    real ( kind = 8 ) h
    integer ( kind = 4 ) i
    integer ( kind = 4 ) ind
    integer ( kind = 4 ) iop
    real ( kind = 8 ) j
    real ( kind = 8 ) l
    integer ( kind = 4 ) m
    integer ( kind = 4 ) n
    integer ( kind = 4 ) n_max
    real ( kind = 8 ) qans
    real ( kind = 8 ) r
    real ( kind = 8 ) rexp
    real ( kind = 8 ) rlog
    real ( kind = 8 ), parameter :: rt2pin = 0.398942280401433D+00
    real ( kind = 8 ) rta
    real ( kind = 8 ), parameter :: rtpi = 1.77245385090552D+00
    real ( kind = 8 ) rtx
    real ( kind = 8 ) s
    real ( kind = 8 ) sum1
    real ( kind = 8 ) t
    real ( kind = 8 ) t1
    real ( kind = 8 ) tol
    real ( kind = 8 ) twoa
    real ( kind = 8 ) u
    real ( kind = 8 ) w
    real ( kind = 8 ) wk(20)
    real ( kind = 8 ) x
    real ( kind = 8 ) x0
    real ( kind = 8 ) x00(3)
    real ( kind = 8 ) y
    real ( kind = 8 ) z

    data big(1)/20.0D+00/,big(2)/14.0D+00/,big(3)/10.0D+00/
    data e00(1)/0.25D-03/,e00(2)/0.25D-01/,e00(3)/0.14D+00/
    data x00(1)/31.0D+00/,x00(2)/17.0D+00/,x00(3)/9.7D+00/
    data d0(1)/0.833333333333333D-01/
    data d0(2)/-0.148148148148148D-01/
    data d0(3)/0.115740740740741D-02/,d0(4)/0.352733686067019D-03/
    data d0(5)/-0.178755144032922D-03/,d0(6)/0.391926317852244D-04/
    data d0(7)/-0.218544851067999D-05/,d0(8)/-0.185406221071516D-05/
    data d0(9)/0.829671134095309D-06/,d0(10)/-0.176659527368261D-06/
    data d0(11)/0.670785354340150D-08/,d0(12)/0.102618097842403D-07/
    data d0(13)/-0.438203601845335D-08/
    data d10/-0.185185185185185D-02/,d1(1)/-0.347222222222222D-02/
    data d1(2)/0.264550264550265D-02/,d1(3)/-0.990226337448560D-03/
    data d1(4)/0.205761316872428D-03/,d1(5)/-0.401877572016461D-06/
    data d1(6)/-0.180985503344900D-04/,d1(7)/0.764916091608111D-05/
    data d1(8)/-0.161209008945634D-05/,d1(9)/0.464712780280743D-08/
    data d1(10)/0.137863344691572D-06/,d1(11)/-0.575254560351770D-07/
    data d1(12)/0.119516285997781D-07/
    data d20/0.413359788359788D-02/,d2(1)/-0.268132716049383D-02/
    data d2(2)/0.771604938271605D-03/,d2(3)/0.200938786008230D-05/
    data d2(4)/-0.107366532263652D-03/,d2(5)/0.529234488291201D-04/
    data d2(6)/-0.127606351886187D-04/,d2(7)/0.342357873409614D-07/
    data d2(8)/0.137219573090629D-05/,d2(9)/-0.629899213838006D-06/
    data d2(10)/0.142806142060642D-06/
    data d30/0.649434156378601D-03/,d3(1)/0.229472093621399D-03/
    data d3(2)/-0.469189494395256D-03/,d3(3)/0.267720632062839D-03/
    data d3(4)/-0.756180167188398D-04/,d3(5)/-0.239650511386730D-06/
    data d3(6)/0.110826541153473D-04/,d3(7)/-0.567495282699160D-05/
    data d3(8)/0.142309007324359D-05/
    data d40/-0.861888290916712D-03/,d4(1)/0.784039221720067D-03/
    data d4(2)/-0.299072480303190D-03/,d4(3)/-0.146384525788434D-05/
    data d4(4)/0.664149821546512D-04/,d4(5)/-0.396836504717943D-04/
    data d4(6)/0.113757269706784D-04/
    data d50/-0.336798553366358D-03/,d5(1)/-0.697281375836586D-04/
    data d5(2)/0.277275324495939D-03/,d5(3)/-0.199325705161888D-03/
    data d5(4)/0.679778047793721D-04/
    data d60/0.531307936463992D-03/,d6(1)/-0.592166437353694D-03/
    data d6(2)/0.270878209671804D-03/
    data d70 / 0.344367606892378D-03/

    e = epsilon ( 1.0D+00 )

    if ( a < 0.0D+00 .or. x < 0.0D+00 ) then
        ans = 2.0D+00
        return
    end if

    if ( a == 0.0D+00 .and. x == 0.0D+00 ) then
        ans = 2.0D+00
        return
    end if

    if ( a * x == 0.0D+00 ) then
        if ( x <= a ) then
            ans = 0.0D+00
            qans = 1.0D+00
        else
            ans = 1.0D+00
            qans = 0.0D+00
        end if
        return
    end if

    iop = ind + 1
    if ( iop /= 1 .and. iop /= 2 ) iop = 3
    acc = max ( acc0(iop), e )
    e0 = e00(iop)
    x0 = x00(iop)
    !
    !  Select the appropriate algorithm.
    !
    if ( 1.0D+00 <= a ) then
        go to 10
    end if

    if ( a == 0.5D+00 ) then
        go to 390
    end if

    if ( x < 1.1D+00 ) then
        go to 160
    end if

    t1 = a * log ( x ) - x
    u = a * exp ( t1 )

    if ( u == 0.0D+00 ) then
        ans = 1.0D+00
        qans = 0.0D+00
        return
    end if

    r = u * ( 1.0D+00 + gam1 ( a ) )
    go to 250

10  continue

    if ( big(iop) <= a ) then
        go to 30
    end if

    if ( x < a .or. x0 <= x ) then
        go to 20
    end if

    twoa = a + a
    m = int ( twoa )

    if ( twoa == real ( m, kind = 8 ) ) then
        i = m / 2
        if ( a == real ( i, kind = 8 ) ) then
            go to 210
        end if
        go to 220
    end if

20  continue

    t1 = a * log ( x ) - x
    r = exp ( t1 ) / gamma ( a )
    go to 40

30  continue

    l = x / a

    if ( l == 0.0D+00 ) then
        ans = 0.0D+00
        qans = 1.0D+00
        return
    end if

    s = 0.5D+00 + ( 0.5D+00 - l )
    z = rlog ( l )
    if ( 700.0D+00 / a <= z ) then
        go to 410
    end if

    y = a * z
    rta = sqrt ( a )

    if ( abs ( s ) <= e0 / rta ) then
        go to 330
    end if

    if ( abs ( s ) <= 0.4D+00 ) then
        go to 270
    end if

    t = ( 1.0D+00 / a )**2
    t1 = ((( 0.75D+00 * t - 1.0D+00 ) * t + 3.5D+00 ) &
        * t - 105.0D+00 ) / ( a * 1260.0D+00 )
    t1 = t1 - y
    r = rt2pin * rta * exp ( t1 )

40  continue

    if ( r == 0.0D+00 ) then
        if ( x <= a ) then
            ans = 0.0D+00
            qans = 1.0D+00
        else
            ans = 1.0D+00
            qans = 0.0D+00
        end if
        return
    end if

    if ( x <= max ( a, alog10 ) ) then
        go to 50
    end if

    if ( x < x0 ) then
        go to 250
    end if

    go to 100
    !
    !  Taylor series for P/R.
    !
50  continue

    apn = a + 1.0D+00
    t = x / apn
    wk(1) = t

    n = 20

    do i = 2, 20
        apn = apn + 1.0D+00
        t = t * ( x / apn )
        if ( t <= 1.0D-03 ) then
            n = i
            exit
        end if
        wk(i) = t
    end do

    sum1 = t

    tol = 0.5D+00 * acc

    do

        apn = apn + 1.0D+00
        t = t * ( x / apn )
        sum1 = sum1 + t

        if ( t <= tol ) then
            exit
        end if

    end do

    n_max = n - 1
    do m = 1, n_max
        n = n - 1
        sum1 = sum1 + wk(n)
    end do

    ans = ( r / a ) * ( 1.0D+00 + sum1 )
    qans = 0.5D+00 + ( 0.5D+00 - ans )
    return
    !
    !  Asymptotic expansion.
    !
100 continue

    amn = a - 1.0D+00
    t = amn / x
    wk(1) = t

    n = 20

    do i = 2, 20
        amn = amn - 1.0D+00
        t = t * ( amn / x )
        if ( abs ( t ) <= 1.0D-03 ) then
            n = i
            exit
        end if
        wk(i) = t
    end do

    sum1 = t

    do

        if ( abs ( t ) <= acc ) then
            exit
        end if

        amn = amn - 1.0D+00
        t = t * ( amn / x )
        sum1 = sum1 + t

    end do

    n_max = n - 1
    do m = 1, n_max
        n = n - 1
        sum1 = sum1 + wk(n)
    end do
    qans = ( r / x ) * ( 1.0D+00 + sum1 )
    ans = 0.5D+00 + ( 0.5D+00 - qans )
    return
    !
    !  Taylor series for P(A,X)/X**A
    !
160 continue

    an = 3.0D+00
    c = x
    sum1 = x / ( a + 3.0D+00 )
    tol = 3.0D+00 * acc / ( a + 1.0D+00 )

    do

        an = an + 1.0D+00
        c = -c * ( x / an )
        t = c / ( a + an )
        sum1 = sum1 + t

        if ( abs ( t ) <= tol ) then
            exit
        end if

    end do

    j = a * x * ( ( sum1 / 6.0D+00 - 0.5D+00 / &
        ( a +  2.0D+00  ) ) * x + 1.0D+00 &
        / ( a + 1.0D+00 ) )

    z = a * log ( x )
    h = gam1 ( a )
    g = 1.0D+00 + h

    if ( x < 0.25D+00 ) then
        go to 180
    end if

    if ( a < x / 2.59D+00 ) then
        go to 200
    end if

    go to 190

180 continue

    if ( -0.13394D+00 < z ) then
        go to 200
    end if

190 continue

    w = exp ( z )
    ans = w * g * ( 0.5D+00 + ( 0.5D+00 - j ))
    qans = 0.5D+00 + ( 0.5D+00 - ans )
    return

200 continue

    l = rexp ( z )
    w = 0.5D+00 + ( 0.5D+00 + l )
    qans = ( w * j - l ) * g - h

    if ( qans < 0.0D+00 ) then
        ans = 1.0D+00
        qans = 0.0D+00
        return
    end if

    ans = 0.5D+00 + ( 0.5D+00 - qans )
    return
    !
    !  Finite sums for Q when 1 <= A and 2*A is an integer.
    !
210 continue

    sum1 = exp ( - x )
    t = sum1
    n = 1
    c = 0.0D+00
    go to 230

220 continue

    rtx = sqrt ( x )
    sum1 = error_fc ( 0, rtx )
    t = exp ( -x ) / ( rtpi * rtx )
    n = 0
    c = -0.5D+00

230 continue

    do while ( n /= i )
        n = n + 1
        c = c + 1.0D+00
        t = ( x * t ) / c
        sum1 = sum1 + t
    end do

240 continue

    qans = sum1
    ans = 0.5D+00 + ( 0.5D+00 - qans )
    return
    !
    !  Continued fraction expansion.
    !
250 continue

    tol = max ( 5.0D+00 * e, acc )
    a2nm1 = 1.0D+00
    a2n = 1.0D+00
    b2nm1 = x
    b2n = x + ( 1.0D+00 - a )
    c = 1.0D+00

    do

        a2nm1 = x * a2n + c * a2nm1
        b2nm1 = x * b2n + c * b2nm1
        am0 = a2nm1 / b2nm1
        c = c + 1.0D+00
        cma = c - a
        a2n = a2nm1 + cma * a2n
        b2n = b2nm1 + cma * b2n
        an0 = a2n / b2n

        if ( abs ( an0 - am0 ) < tol * an0 ) then
            exit
        end if

    end do

    qans = r * an0
    ans = 0.5D+00 + ( 0.5D+00 - qans )
    return
    !
    !  General Temme expansion.
    !
270 continue

    if ( abs ( s ) <= 2.0D+00 * e .and. 3.28D-03 < a * e * e ) then
        ans =  2.0D+00
        return
    end if

    c = exp ( - y )
    w = 0.5D+00 * error_fc ( 1, sqrt ( y ) )
    u = 1.0D+00 / a
    z = sqrt ( z + z )

    if ( l < 1.0D+00 ) then
        z = -z
    end if

    if ( iop < 2 ) then

        if ( abs ( s ) <= 1.0D-03 ) then

            c0 = ((((((     &
                d0(7)   &
                * z + d0(6) ) &
                * z + d0(5) ) &
                * z + d0(4) ) &
                * z + d0(3) ) &
                * z + d0(2) ) &
                * z + d0(1) ) &
                * z - 1.0D+00 / 3.0D+00

            c1 = (((((      &
                d1(6)   &
                * z + d1(5) ) &
                * z + d1(4) ) &
                * z + d1(3) ) &
                * z + d1(2) ) &
                * z + d1(1) ) &
                * z + d10

            c2 = ((((d2(5)*z+d2(4))*z+d2(3))*z+d2(2))*z+d2(1))*z + d20

            c3 = (((d3(4)*z+d3(3))*z+d3(2))*z+d3(1))*z + d30

            c4 = ( d4(2) * z + d4(1) ) * z + d40
            c5 = ( d5(2) * z + d5(1) ) * z + d50
            c6 = d6(1) * z + d60

            t = (((((( d70 &
                * u + c6 ) &
                * u + c5 ) &
                * u + c4 ) &
                * u + c3 ) &
                * u + c2 ) &
                * u + c1 ) &
                * u + c0

        else

            c0 = (((((((((((( &
                d0(13)   &
                * z + d0(12) ) &
                * z + d0(11) ) &
                * z + d0(10) ) &
                * z + d0(9)  ) &
                * z + d0(8)  ) &
                * z + d0(7)  ) &
                * z + d0(6)  ) &
                * z + d0(5)  ) &
                * z + d0(4)  ) &
                * z + d0(3)  ) &
                * z + d0(2)  ) &
                * z + d0(1)  ) &
                * z - 1.0D+00 / 3.0D+00

            c1 = ((((((((((( &
                d1(12) &
                * z + d1(11) &
                ) * z + d1(10) &
                ) * z + d1(9)  &
                ) * z + d1(8)  &
                ) * z + d1(7)  &
                ) * z + d1(6)  &
                ) * z + d1(5)  &
                ) * z + d1(4)  &
                ) * z + d1(3)  &
                ) * z + d1(2)  &
                ) * z + d1(1)  &
                ) * z + d10

            c2 = ((((((((( &
                d2(10) &
                * z + d2(9) &
                ) * z + d2(8) &
                ) * z + d2(7) &
                ) * z + d2(6) &
                ) * z + d2(5) &
                ) * z + d2(4) &
                ) * z + d2(3) &
                ) * z + d2(2) &
                ) * z + d2(1) &
                ) * z + d20

            c3 = ((((((( &
                d3(8) &
                * z + d3(7) &
                ) * z + d3(6) &
                ) * z + d3(5) &
                ) * z + d3(4) &
                ) * z + d3(3) &
                ) * z + d3(2) &
                ) * z + d3(1) &
                ) * z + d30

            c4 = ((((( d4(6)*z+d4(5))*z+d4(4))*z+d4(3))*z+d4(2))*z+d4(1))*z + d40

            c5 = (((d5(4)*z+d5(3))*z+d5(2))*z+d5(1))*z + d50

            c6 = ( d6(2) * z + d6(1) ) * z + d60

            t = ((((((   &
                d70    &
                * u + c6 ) &
                * u + c5 ) &
                * u + c4 ) &
                * u + c3 ) &
                * u + c2 ) &
                * u + c1 ) &
                * u + c0

        end if

    else if ( iop == 2 ) then

        c0 = (((((      &
            d0(6)   &
            * z + d0(5) ) &
            * z + d0(4) ) &
            * z + d0(3) ) &
            * z + d0(2) ) &
            * z + d0(1) ) &
            * z - 1.0D+00 / 3.0D+00

        c1 = ((( d1(4) * z + d1(3) ) * z + d1(2) ) * z + d1(1) ) * z + d10
        c2 = d2(1) * z + d20
        t = ( c2 * u + c1 ) * u + c0

    else if ( 2 < iop ) then

        t = (( d0(3) * z + d0(2) ) * z + d0(1) ) * z - 1.0D+00 / 3.0D+00

    end if

310 continue

    if ( 1.0D+00 <= l ) then
        qans = c * ( w + rt2pin * t / rta )
        ans = 0.5D+00 + ( 0.5D+00 - qans )
    else
        ans = c * ( w - rt2pin * t / rta )
        qans = 0.5D+00 + ( 0.5D+00 - ans )
    end if

    return
    !
    !  Temme expansion for L = 1
    !
330 continue

    if ( 3.28D-03 < a * e * e ) then
        ans =  2.0D+00
        return
    end if

    c = 0.5D+00 + ( 0.5D+00 - y )
    w = ( 0.5D+00 - sqrt ( y ) &
        * ( 0.5D+00 &
        + ( 0.5D+00 - y / 3.0D+00 ) ) / rtpi ) / c
    u = 1.0D+00 / a
    z = sqrt ( z + z )

    if ( l < 1.0D+00 ) then
        z = -z
    end if

    if ( iop < 2 ) then

        c0 = ((((((     &
            d0(7)   &
            * z + d0(6) ) &
            * z + d0(5) ) &
            * z + d0(4) ) &
            * z + d0(3) ) &
            * z + d0(2) ) &
            * z + d0(1) ) &
            * z - 1.0D+00 / 3.0D+00

        c1 = (((((      &
            d1(6)   &
            * z + d1(5) ) &
            * z + d1(4) ) &
            * z + d1(3) ) &
            * z + d1(2) ) &
            * z + d1(1) ) &
            * z + d10

        c2 = ((((d2(5)*z+d2(4))*z+d2(3))*z+d2(2))*z+d2(1))*z + d20

        c3 = (((d3(4)*z+d3(3))*z+d3(2))*z+d3(1))*z + d30

        c4 = ( d4(2) * z + d4(1) ) * z + d40
        c5 = ( d5(2) * z + d5(1) ) * z + d50
        c6 = d6(1) * z + d60

        t = (((((( d70 &
            * u + c6 ) &
            * u + c5 ) &
            * u + c4 ) &
            * u + c3 ) &
            * u + c2 ) &
            * u + c1 ) &
            * u + c0

    else if ( iop == 2 ) then

        c0 = ( d0(2) * z + d0(1) ) * z - 1.0D+00 / 3.0D+00
        c1 = d1(1) * z + d10
        t = ( d20 * u + c1 ) * u + c0

    else if ( 2 < iop ) then

        t = d0(1) * z - 1.0D+00 / 3.0D+00

    end if

    go to 310
    !
    !  Special cases
    !
390 continue

    if ( x < 0.25D+00 ) then
        ans = error_f ( sqrt ( x ) )
        qans = 0.5D+00 + ( 0.5D+00 - ans )
    else
        qans = error_fc ( 0, sqrt ( x ) )
        ans = 0.5D+00 + ( 0.5D+00 - qans )
    end if

    return

410 continue

    if ( abs ( s ) <= 2.0D+00 * e ) then
        ans =  2.0D+00
        return
    end if

    if ( x <= a ) then
        ans = 0.0D+00
        qans = 1.0D+00
    else
        ans = 1.0D+00
        qans = 0.0D+00
    end if

    return
    end
    subroutine gamma_inc_inv ( a, x, x0, p, q, ierr )

    !*****************************************************************************80
    !
    !! GAMMA_INC_INV computes the inverse incomplete gamma ratio function.
    !
    !  Discussion:
    !
    !    The routine is given positive A, and nonnegative P and Q where P + Q = 1.
    !    The value X is computed with the property that P(A,X) = P and Q(A,X) = Q.
    !    Schroder iteration is employed.  The routine attempts to compute X
    !    to 10 significant digits if this is possible for the particular computer
    !    arithmetic being used.
    !
    !  Author:
    !
    !    Alfred Morris,
    !    Naval Surface Weapons Center,
    !    Dahlgren, Virginia.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, the parameter in the incomplete gamma
    !    ratio.  A must be positive.
    !
    !    Output, real ( kind = 8 ) X, the computed point for which the
    !    incomplete gamma functions have the values P and Q.
    !
    !    Input, real ( kind = 8 ) X0, an optional initial approximation
    !    for the solution X.  If the user does not want to supply an
    !    initial approximation, then X0 should be set to 0, or a negative
    !    value.
    !
    !    Input, real ( kind = 8 ) P, Q, the values of the incomplete gamma
    !    functions, for which the corresponding argument is desired.
    !
    !    Output, integer ( kind = 4 ) IERR, error flag.
    !    0, the solution was obtained. Iteration was not used.
    !    0 < K, The solution was obtained. IERR iterations were performed.
    !    -2, A <= 0
    !    -3, No solution was obtained. The ratio Q/A is too large.
    !    -4, P + Q /= 1
    !    -6, 20 iterations were performed. The most recent value obtained
    !        for X is given.  This cannot occur if X0 <= 0.
    !    -7, Iteration failed. No value is given for X.
    !        This may occur when X is approximately 0.
    !    -8, A value for X has been obtained, but the routine is not certain
    !        of its accuracy.  Iteration cannot be performed in this
    !        case. If X0 <= 0, this can occur only when P or Q is
    !        approximately 0. If X0 is positive then this can occur when A is
    !        exceedingly close to X and A is extremely large (say A .GE. 1.E20).
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ), parameter :: a0 = 3.31125922108741D+00
    real ( kind = 8 ), parameter :: a1 = 11.6616720288968D+00
    real ( kind = 8 ), parameter :: a2 = 4.28342155967104D+00
    real ( kind = 8 ), parameter :: a3 = 0.213623493715853D+00
    real ( kind = 8 ) alnrel
    real ( kind = 8 ) am1
    real ( kind = 8 ) amax
    real ( kind = 8 ), dimension(2) :: amin = (/ &
        500.0D+00, 100.0D+00 /)
    real ( kind = 8 ) ap1
    real ( kind = 8 ) ap2
    real ( kind = 8 ) ap3
    real ( kind = 8 ) apn
    real ( kind = 8 ) b
    real ( kind = 8 ), parameter :: b1 = 6.61053765625462D+00
    real ( kind = 8 ), parameter :: b2 = 6.40691597760039D+00
    real ( kind = 8 ), parameter :: b3 = 1.27364489782223D+00
    real ( kind = 8 ), parameter :: b4 = .036117081018842D+00
    real ( kind = 8 ), dimension ( 2 ) :: bmin = (/ &
        1.0D-28, 1.0D-13 /)
    real ( kind = 8 ), parameter :: c = 0.577215664901533D+00
    real ( kind = 8 ) c1
    real ( kind = 8 ) c2
    real ( kind = 8 ) c3
    real ( kind = 8 ) c4
    real ( kind = 8 ) c5
    real ( kind = 8 ) d
    real ( kind = 8 ), dimension ( 2 ) :: dmin = (/ &
        1.0D-06, 1.0D-04 /)
    real ( kind = 8 ) e
    real ( kind = 8 ) e2
    real ( kind = 8 ), dimension ( 2 ) :: emin = (/ &
        2.0D-03, 6.0D-03 /)
    real ( kind = 8 ) eps
    real ( kind = 8 ), dimension ( 2 ) :: eps0 = (/ &
        1.0D-10, 1.0D-08 /)
    real ( kind = 8 ) g
    real ( kind = 8 ) gamma_log
    real ( kind = 8 ) gamma_ln1
    real ( kind = 8 ) gamma
    real ( kind = 8 ) h
    real ( kind = 8 ), parameter :: half = 0.5D+00
    integer ( kind = 4 ) ierr
    integer ( kind = 4 ) iop
    real ( kind = 8 ), parameter :: ln10 = 2.302585D+00
    real ( kind = 8 ) p
    real ( kind = 8 ) pn
    real ( kind = 8 ) q
    real ( kind = 8 ) qg
    real ( kind = 8 ) qn
    real ( kind = 8 ) r
    real ( kind = 8 ) rcomp
    real ( kind = 8 ) rta
    real ( kind = 8 ) s
    real ( kind = 8 ) s2
    real ( kind = 8 ) sum1
    real ( kind = 8 ) t
    real ( kind = 8 ), parameter :: tol = 1.0D-05
    real ( kind = 8 ), parameter :: two =  2.0D+00
    real ( kind = 8 ) u
    real ( kind = 8 ) w
    real ( kind = 8 ) x
    real ( kind = 8 ) x0
    real ( kind = 8 ) xn
    real ( kind = 8 ) y
    real ( kind = 8 ) z

    e = epsilon ( e )

    x = 0.0D+00

    if ( a <= 0.0D+00 ) then
        ierr = -2
        return
    end if

    t = p + q - 1.0D+00

    if ( e < abs ( t ) ) then
        ierr = -4
        return
    end if

    ierr = 0

    if ( p == 0.0D+00 ) then
        return
    end if

    if ( q == 0.0D+00 ) then
        x = huge ( x )
        return
    end if

    if ( a == 1.0D+00 ) then
        if ( 0.9D+00 <= q ) then
            x = -alnrel ( - p )
        else
            x = -log ( q )
        end if
        return
    end if

    e2 = two * e
    amax = 0.4D-10 / ( e * e )

    if ( 1.0D-10 < e ) then
        iop = 2
    else
        iop = 1
    end if

    eps = eps0(iop)
    xn = x0

    if ( 0.0D+00 < x0 ) then
        go to 160
    end if
    !
    !  Selection of the initial approximation XN of X when A < 1.
    !
    if ( 1.0D+00 < a ) then
        go to 80
    end if

    g = gamma ( a + 1.0D+00 )
    qg = q * g

    if ( qg == 0.0D+00 ) then
        x = huge ( x )
        ierr = -8
        return
    end if

    b = qg / a

    if ( 0.6D+00 * a < qg ) then
        go to 40
    end if

    if ( a < 0.30D+00 .and. 0.35D+00 <= b ) then
        t = exp ( - ( b + c ) )
        u = t * exp ( t )
        xn = t * exp ( u )
        go to 160
    end if

    if ( 0.45D+00 <= b ) then
        go to 40
    end if

    if ( b == 0.0D+00 ) then
        x = huge ( x )
        ierr = -8
        return
    end if

    y = -log ( b )
    s = half + ( half - a )
    z = log ( y )
    t = y - s * z

    if ( 0.15D+00 <= b ) then
        xn = y - s * log ( t ) - log ( 1.0D+00 + s / ( t + 1.0D+00 ) )
        go to 220
    end if

    if ( 0.01D+00 < b ) then
        u = ( ( t + two * ( 3.0D+00 - a ) ) * t &
            + ( two - a ) * ( 3.0D+00 - a )) / &
            ( ( t + ( 5.0D+00 - a ) ) * t + two )
        xn = y - s * log ( t ) - log ( u )
        go to 220
    end if

30  continue

    c1 = -s * z
    c2 = -s * ( 1.0D+00 + c1 )

    c3 = s * (( half * c1 &
        + ( two - a ) ) * c1 + ( 2.5D+00 - 1.5D+00 * a ) )

    c4 = -s * ((( c1 / 3.0D+00 + ( 2.5D+00 - 1.5D+00 * a ) ) * c1 &
        + ( ( a - 6.0D+00 ) * a + 7.0D+00 ) ) &
        * c1 + ( ( 11.0D+00 * a - 46.0D+00 ) * a + 47.0D+00 ) / 6.0D+00 )

    c5 = -s * (((( - c1 / 4.0D+00 + ( 11.0D+00 * a - 17.0D+00 ) / 6.0D+00 ) * c1 &
        + ( ( -3.0D+00 * a + 13.0D+00 ) * a - 13.0D+00 ) ) * c1 &
        + half &
        * ( ( ( two * a - 25.0D+00 ) * a + 72.0D+00 ) &
        * a - 61.0D+00 ) ) * c1 &
        + ( ( ( 25.0D+00 * a - 195.0D+00 ) * a &
        + 477.0D+00 ) * a - 379.0D+00 ) / 12.0D+00 )

    xn = (((( c5 / y + c4 ) / y + c3 ) / y + c2 ) / y + c1 ) + y

    if ( 1.0D+00 < a ) then
        go to 220
    end if

    if ( bmin(iop) < b ) then
        go to 220
    end if

    x = xn
    return

40  continue

    if ( b * q <= 1.0D-08 ) then
        xn = exp ( - ( q / a + c ))
    else if ( 0.9D+00 < p ) then
        xn = exp ( ( alnrel ( - q ) + gamma_ln1 ( a )) / a )
    else
        xn = exp ( log ( p * g ) / a )
    end if

    if ( xn == 0.0D+00 ) then
        ierr = -3
        return
    end if

    t = half + ( half - xn / ( a + 1.0D+00 ))
    xn = xn / t
    go to 160
    !
    !  Selection of the initial approximation XN of X when 1 < A.
    !
80  continue

    if ( 0.5D+00 < q ) then
        w = log ( p )
    else
        w = log ( q )
    end if

    t = sqrt ( - two * w )

    s = t - ((( a3 * t + a2 ) * t + a1 ) * t + a0 ) / (((( &
        b4 * t + b3 ) * t + b2 ) * t + b1 ) * t + 1.0D+00 )

    if ( 0.5D+00 < q ) then
        s = -s
    end if

    rta = sqrt ( a )
    s2 = s * s

    xn = a + s * rta + ( s2 - 1.0D+00 ) / 3.0D+00 + s * ( s2 - 7.0D+00 ) &
        / ( 36.0D+00 * rta ) - ( ( 3.0D+00 * s2 + 7.0D+00 ) * s2 - 16.0D+00 ) &
        / ( 810.0D+00 * a ) + s * (( 9.0D+00 * s2 + 256.0D+00 ) * s2 - 433.0D+00 ) &
        / ( 38880.0D+00 * a * rta )

    xn = max ( xn, 0.0D+00 )

    if ( amin(iop) <= a ) then

        x = xn
        d = half + ( half - x / a )

        if ( abs ( d ) <= dmin(iop) ) then
            return
        end if

    end if

110 continue

    if ( p <= 0.5D+00 ) then
        go to 130
    end if

    if ( xn < 3.0D+00 * a ) then
        go to 220
    end if

    y = - ( w + gamma_log ( a ) )
    d = max ( two, a * ( a - 1.0D+00 ) )

    if ( ln10 * d <= y ) then
        s = 1.0D+00 - a
        z = log ( y )
        go to 30
    end if

120 continue

    t = a - 1.0D+00
    xn = y + t * log ( xn ) - alnrel ( -t / ( xn + 1.0D+00 ) )
    xn = y + t * log ( xn ) - alnrel ( -t / ( xn + 1.0D+00 ) )
    go to 220

130 continue

    ap1 = a + 1.0D+00

    if ( 0.70D+00 * ap1 < xn ) then
        go to 170
    end if

    w = w + gamma_log ( ap1 )

    if ( xn <= 0.15 * ap1 ) then
        ap2 = a + two
        ap3 = a + 3.0D+00
        x = exp ( ( w + x ) / a )
        x = exp ( ( w + x - log ( 1.0D+00 + ( x / ap1 ) &
            * ( 1.0D+00 + x / ap2 ) ) ) / a )
        x = exp ( ( w + x - log ( 1.0D+00 + ( x / ap1 ) &
            * ( 1.0D+00 + x / ap2 ) ) ) / a )
        x = exp ( ( w + x - log ( 1.0D+00 + ( x / ap1 ) &
            * ( 1.0D+00 + ( x / ap2 ) &
            * ( 1.0D+00 + x / ap3 ) ) ) ) / a )
        xn = x

        if ( xn <= 1.0D-02 * ap1 ) then
            if ( xn <= emin(iop) * ap1 ) then
                return
            end if
            go to 170
        end if

    end if

    apn = ap1
    t = xn / apn
    sum1 = 1.0D+00 + t

    do

        apn = apn + 1.0D+00
        t = t * ( xn / apn )
        sum1 = sum1 + t

        if ( t <= 1.0D-04 ) then
            exit
        end if

    end do

    t = w - log ( sum1 )
    xn = exp ( ( xn + t ) / a )
    xn = xn * ( 1.0D+00 - ( a * log ( xn ) - xn - t ) / ( a - xn ) )
    go to 170
    !
    !  Schroder iteration using P.
    !
160 continue

    if ( 0.5D+00 < p ) then
        go to 220
    end if

170 continue

    if ( p <= 1.0D+10 * tiny ( p ) ) then
        x = xn
        ierr = -8
        return
    end if

    am1 = ( a - half ) - half

180 continue

    if ( amax < a ) then
        d = half + ( half - xn / a )
        if ( abs ( d ) <= e2 ) then
            x = xn
            ierr = -8
            return
        end if
    end if

190 continue

    if ( 20 <= ierr ) then
        ierr = -6
        return
    end if

    ierr = ierr + 1
    call gamma_inc ( a, xn, pn, qn, 0 )

    if ( pn == 0.0D+00 .or. qn == 0.0D+00 ) then
        x = xn
        ierr = -8
        return
    end if

    r = rcomp ( a, xn )

    if ( r == 0.0D+00 ) then
        x = xn
        ierr = -8
        return
    end if

    t = ( pn - p ) / r
    w = half * ( am1 - xn )

    if ( abs ( t ) <= 0.1D+00 .and. abs ( w * t ) <= 0.1D+00 ) then
        go to 200
    end if

    x = xn * ( 1.0D+00 - t )

    if ( x <= 0.0D+00 ) then
        ierr = -7
        return
    end if

    d = abs ( t )
    go to 210

200 continue

    h = t * ( 1.0D+00 + w * t )
    x = xn * ( 1.0D+00 - h )

    if ( x <= 0.0D+00 ) then
        ierr = -7
        return
    end if

    if ( 1.0D+00 <= abs ( w ) .and. abs ( w ) * t * t <= eps ) then
        return
    end if

    d = abs ( h )

210 continue

    xn = x

    if ( d <= tol ) then

        if ( d <= eps ) then
            return
        end if

        if ( abs ( p - pn ) <= tol * p ) then
            return
        end if

    end if

    go to 180
    !
    !  Schroder iteration using Q.
    !
220 continue

    if ( q <= 1.0D+10 * tiny ( q ) ) then
        x = xn
        ierr = -8
        return
    end if

    am1 = ( a - half ) - half

230 continue

    if ( amax < a ) then
        d = half + ( half - xn / a )
        if ( abs ( d ) <= e2 ) then
            x = xn
            ierr = -8
            return
        end if
    end if

    if ( 20 <= ierr ) then
        ierr = -6
        return
    end if

    ierr = ierr + 1
    call gamma_inc ( a, xn, pn, qn, 0 )

    if ( pn == 0.0D+00 .or. qn == 0.0D+00 ) then
        x = xn
        ierr = -8
        return
    end if

    r = rcomp ( a, xn )

    if ( r == 0.0D+00 ) then
        x = xn
        ierr = -8
        return
    end if

    t = ( q - qn ) / r
    w = half * ( am1 - xn )

    if ( abs ( t ) <= 0.1 .and. abs ( w * t ) <= 0.1 ) then
        go to 250
    end if

    x = xn * ( 1.0D+00 - t )

    if ( x <= 0.0D+00 ) then
        ierr = -7
        return
    end if

    d = abs ( t )
    go to 260

250 continue

    h = t * ( 1.0D+00 + w * t )
    x = xn * ( 1.0D+00 - h )

    if ( x <= 0.0D+00 ) then
        ierr = -7
        return
    end if

    if ( 1.0D+00 <= abs ( w ) .and. abs ( w ) * t * t <= eps ) then
        return
    end if

    d = abs ( h )

260 continue

    xn = x

    if ( tol < d ) then
        go to 230
    end if

    if ( d <= eps ) then
        return
    end if

    if ( abs ( q - qn ) <= tol * q ) then
        return
    end if

    go to 230
    end
    subroutine gamma_inc_values ( n_data, a, x, fx )

    !*****************************************************************************80
    !
    !! GAMMA_INC_VALUES returns some values of the incomplete Gamma function.
    !
    !  Discussion:
    !
    !    The (normalized) incomplete Gamma function P(A,X) is defined as:
    !
    !      PN(A,X) = 1/GAMMA(A) * Integral ( 0 <= T <= X ) T**(A-1) * exp(-T) dT.
    !
    !    With this definition, for all A and X,
    !
    !      0 <= PN(A,X) <= 1
    !
    !    and
    !
    !      PN(A,INFINITY) = 1.0
    !
    !    Mathematica can compute this value as
    !
    !      1 - GammaRegularized[A,X]
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    08 May 2001
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions,
    !    US Department of Commerce, 1964.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) N_DATA.  The user sets N_DATA to 0
    !    before the first call.  On each call, the routine increments N_DATA by 1,
    !    and returns the corresponding data; when there is no more data, the
    !    output value of N_DATA will be 0 again.
    !
    !    Output, real ( kind = 8 ) A, X, the arguments of the function.
    !
    !    Output, real ( kind = 8 ) FX, the value of the function.
    !
    implicit none

    integer ( kind = 4 ), parameter :: n_max = 20

    real ( kind = 8 ) a
    real ( kind = 8 ), save, dimension ( n_max ) :: a_vec = (/ &
        0.1D+00,  0.1D+00,  0.1D+00,  0.5D+00, &
        0.5D+00,  0.5D+00,  1.0D+00,  1.0D+00, &
        1.0D+00,  1.1D+00,  1.1D+00,  1.1D+00, &
        2.0D+00,  2.0D+00,  2.0D+00,  6.0D+00, &
        6.0D+00, 11.0D+00, 26.0D+00, 41.0D+00 /)
    real ( kind = 8 ) fx
    real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ &
        0.7420263D+00, 0.9119753D+00, 0.9898955D+00, 0.2931279D+00, &
        0.7656418D+00, 0.9921661D+00, 0.0951626D+00, 0.6321206D+00, &
        0.9932621D+00, 0.0757471D+00, 0.6076457D+00, 0.9933425D+00, &
        0.0091054D+00, 0.4130643D+00, 0.9931450D+00, 0.0387318D+00, &
        0.9825937D+00, 0.9404267D+00, 0.4863866D+00, 0.7359709D+00 /)
    integer ( kind = 4 ) n_data
    real ( kind = 8 ) x
    real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ &
        3.1622777D-02, 3.1622777D-01, 1.5811388D+00, 7.0710678D-02, &
        7.0710678D-01, 3.5355339D+00, 0.1000000D+00, 1.0000000D+00, &
        5.0000000D+00, 1.0488088D-01, 1.0488088D+00, 5.2440442D+00, &
        1.4142136D-01, 1.4142136D+00, 7.0710678D+00, 2.4494897D+00, &
        1.2247449D+01, 1.6583124D+01, 2.5495098D+01, 4.4821870D+01 /)

    if ( n_data < 0 ) then
        n_data = 0
    end if

    n_data = n_data + 1

    if ( n_max < n_data ) then
        n_data = 0
        a = 0.0D+00
        x = 0.0D+00
        fx = 0.0D+00
    else
        a = a_vec(n_data)
        x = x_vec(n_data)
        fx = fx_vec(n_data)
    end if

    return
    end
    function gamma_ln1 ( a )

    !*****************************************************************************80
    !
    !! GAMMA_LN1 evaluates ln ( Gamma ( 1 + A ) ), for -0.2 <= A <= 1.25.
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, defines the argument of the function.
    !
    !    Output, real ( kind = 8 ) GAMMA_LN1, the value of ln ( Gamma ( 1 + A ) ).
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) bot
    real ( kind = 8 ) gamma_ln1
    real ( kind = 8 ), parameter :: p0 =  0.577215664901533D+00
    real ( kind = 8 ), parameter :: p1 =  0.844203922187225D+00
    real ( kind = 8 ), parameter :: p2 = -0.168860593646662D+00
    real ( kind = 8 ), parameter :: p3 = -0.780427615533591D+00
    real ( kind = 8 ), parameter :: p4 = -0.402055799310489D+00
    real ( kind = 8 ), parameter :: p5 = -0.673562214325671D-01
    real ( kind = 8 ), parameter :: p6 = -0.271935708322958D-02
    real ( kind = 8 ), parameter :: q1 =  0.288743195473681D+01
    real ( kind = 8 ), parameter :: q2 =  0.312755088914843D+01
    real ( kind = 8 ), parameter :: q3 =  0.156875193295039D+01
    real ( kind = 8 ), parameter :: q4 =  0.361951990101499D+00
    real ( kind = 8 ), parameter :: q5 =  0.325038868253937D-01
    real ( kind = 8 ), parameter :: q6 =  0.667465618796164D-03
    real ( kind = 8 ), parameter :: r0 = 0.422784335098467D+00
    real ( kind = 8 ), parameter :: r1 = 0.848044614534529D+00
    real ( kind = 8 ), parameter :: r2 = 0.565221050691933D+00
    real ( kind = 8 ), parameter :: r3 = 0.156513060486551D+00
    real ( kind = 8 ), parameter :: r4 = 0.170502484022650D-01
    real ( kind = 8 ), parameter :: r5 = 0.497958207639485D-03
    real ( kind = 8 ), parameter :: s1 = 0.124313399877507D+01
    real ( kind = 8 ), parameter :: s2 = 0.548042109832463D+00
    real ( kind = 8 ), parameter :: s3 = 0.101552187439830D+00
    real ( kind = 8 ), parameter :: s4 = 0.713309612391000D-02
    real ( kind = 8 ), parameter :: s5 = 0.116165475989616D-03
    real ( kind = 8 ) top
    real ( kind = 8 ) x

    if ( a < 0.6D+00 ) then

        top = (((((  &
            p6   &
            * a + p5 ) &
            * a + p4 ) &
            * a + p3 ) &
            * a + p2 ) &
            * a + p1 ) &
            * a + p0

        bot = (((((  &
            q6   &
            * a + q5 ) &
            * a + q4 ) &
            * a + q3 ) &
            * a + q2 ) &
            * a + q1 ) &
            * a + 1.0D+00

        gamma_ln1 = -a * ( top / bot )

    else

        x = ( a - 0.5D+00 ) - 0.5D+00

        top = ((((( r5 * x + r4 ) * x + r3 ) * x + r2 ) * x + r1 ) * x + r0 )

        bot = ((((( s5 * x + s4 ) * x + s3 ) * x + s2 ) * x + s1 ) * x + 1.0D+00 )

        gamma_ln1 = x * ( top / bot )

    end if

    return
    end
    function gamma_log ( a )

    !*****************************************************************************80
    !
    !! GAMMA_LOG evaluates ln ( Gamma ( A ) ) for positive A.
    !
    !  Author:
    !
    !    Alfred Morris,
    !    Naval Surface Weapons Center,
    !    Dahlgren, Virginia.
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, the argument of the function.
    !    A should be positive.
    !
    !    Output, real ( kind = 8 ), GAMMA_LOG, the value of ln ( Gamma ( A ) ).
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ), parameter :: c0 =  0.833333333333333D-01
    real ( kind = 8 ), parameter :: c1 = -0.277777777760991D-02
    real ( kind = 8 ), parameter :: c2 =  0.793650666825390D-03
    real ( kind = 8 ), parameter :: c3 = -0.595202931351870D-03
    real ( kind = 8 ), parameter :: c4 =  0.837308034031215D-03
    real ( kind = 8 ), parameter :: c5 = -0.165322962780713D-02
    real ( kind = 8 ), parameter :: d  =  0.418938533204673D+00
    real ( kind = 8 ) gamma_log
    real ( kind = 8 ) gamma_ln1
    integer ( kind = 4 ) i
    integer ( kind = 4 ) n
    real ( kind = 8 ) t
    real ( kind = 8 ) w

    if ( a <= 0.8D+00 ) then

        gamma_log = gamma_ln1 ( a ) - log ( a )

    else if ( a <= 2.25D+00 ) then

        t = ( a - 0.5D+00 ) - 0.5D+00
        gamma_log = gamma_ln1 ( t )

    else if ( a < 10.0D+00 ) then

        n = a - 1.25D+00
        t = a
        w = 1.0D+00
        do i = 1, n
            t = t - 1.0D+00
            w = t * w
        end do

        gamma_log = gamma_ln1 ( t - 1.0D+00 ) + log ( w )

    else

        t = ( 1.0D+00 / a )**2

        w = ((((( c5 * t + c4 ) * t + c3 ) * t + c2 ) * t + c1 ) * t + c0 ) / a

        gamma_log = ( d + w ) + ( a - 0.5D+00 ) &
            * ( log ( a ) - 1.0D+00 )

    end if

    return
    end
    subroutine gamma_rat1 ( a, x, r, p, q, eps )

    !*****************************************************************************80
    !
    !! GAMMA_RAT1 evaluates the incomplete gamma ratio functions P(A,X) and Q(A,X).
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, X, the parameters of the functions.
    !    It is assumed that A <= 1.
    !
    !    Input, real ( kind = 8 ) R, the value exp(-X) * X**A / Gamma(A).
    !
    !    Output, real ( kind = 8 ) P, Q, the values of P(A,X) and Q(A,X).
    !
    !    Input, real ( kind = 8 ) EPS, the tolerance.
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) a2n
    real ( kind = 8 ) a2nm1
    real ( kind = 8 ) am0
    real ( kind = 8 ) an
    real ( kind = 8 ) an0
    real ( kind = 8 ) b2n
    real ( kind = 8 ) b2nm1
    real ( kind = 8 ) c
    real ( kind = 8 ) cma
    real ( kind = 8 ) eps
    real ( kind = 8 ) error_f
    real ( kind = 8 ) error_fc
    real ( kind = 8 ) g
    real ( kind = 8 ) gam1
    real ( kind = 8 ) h
    real ( kind = 8 ) j
    real ( kind = 8 ) l
    real ( kind = 8 ) p
    real ( kind = 8 ) q
    real ( kind = 8 ) r
    real ( kind = 8 ) rexp
    real ( kind = 8 ) sum1
    real ( kind = 8 ) t
    real ( kind = 8 ) tol
    real ( kind = 8 ) w
    real ( kind = 8 ) x
    real ( kind = 8 ) z

    if ( a * x == 0.0D+00 ) then

        if ( x <= a ) then
            p = 0.0D+00
            q = 1.0D+00
        else
            p = 1.0D+00
            q = 0.0D+00
        end if

        return
    end if

    if ( a == 0.5D+00 ) then

        if ( x < 0.25D+00 ) then
            p = error_f ( sqrt ( x ) )
            q = 0.5D+00 + ( 0.5D+00 - p )
        else
            q = error_fc ( 0, sqrt ( x ) )
            p = 0.5D+00 + ( 0.5D+00 - q )
        end if

        return

    end if
    !
    !  Taylor series for P(A,X)/X**A
    !
    if ( x < 1.1D+00 ) then

        an = 3.0
        c = x
        sum1 = x / ( a + 3.0D+00 )
        tol = 0.1D+00 * eps / ( a + 1.0D+00 )

        do

            an = an + 1.0D+00
            c = -c * ( x / an )
            t = c / ( a + an )
            sum1 = sum1 + t

            if ( abs ( t ) <= tol ) then
                exit
            end if

        end do

        j = a * x * ( ( sum1 / 6.0D+00 - 0.5D+00 &
            / ( a +  2.0D+00  ) ) &
            * x + 1.0D+00 / ( a + 1.0D+00 ) )

        z = a * log ( x )
        h = gam1 ( a )
        g = 1.0D+00 + h

        if ( x < 0.25D+00 ) then
            go to 30
        end if

        if ( a < x / 2.59D+00 ) then
            go to 50
        else
            go to 40
        end if

30      continue

        if ( -0.13394D+00 < z ) then
            go to 50
        end if

40      continue

        w = exp ( z )
        p = w * g * ( 0.5D+00 + ( 0.5D+00 - j ))
        q = 0.5D+00 + ( 0.5D+00 - p )
        return

50      continue

        l = rexp ( z )
        w = 0.5D+00 + ( 0.5D+00 + l )
        q = ( w * j - l ) * g - h

        if  ( q < 0.0D+00 ) then
            p = 1.0D+00
            q = 0.0D+00
        else
            p = 0.5D+00 + ( 0.5D+00 - q )
        end if
        !
        !  Continued fraction expansion.
        !
    else

        a2nm1 = 1.0D+00
        a2n = 1.0D+00
        b2nm1 = x
        b2n = x + ( 1.0D+00 - a )
        c = 1.0D+00

        do

            a2nm1 = x * a2n + c * a2nm1
            b2nm1 = x * b2n + c * b2nm1
            am0 = a2nm1 / b2nm1
            c = c + 1.0D+00
            cma = c - a
            a2n = a2nm1 + cma * a2n
            b2n = b2nm1 + cma * b2n
            an0 = a2n / b2n

            if ( abs ( an0 - am0 ) < eps * an0 ) then
                exit
            end if

        end do

        q = r * an0
        p = 0.5D+00 + ( 0.5D+00 - q )

    end if

    return
    end
    subroutine gamma_values ( n_data, x, fx )

    !*****************************************************************************80
    !
    !! GAMMA_VALUES returns some values of the Gamma function.
    !
    !  Definition:
    !
    !    Gamma(Z) = Integral ( 0 <= T < Infinity) T**(Z-1) exp(-T) dT
    !
    !  Recursion:
    !
    !    Gamma(X+1) = X * Gamma(X)
    !
    !  Restrictions:
    !
    !    0 < X ( a software restriction).
    !
    !  Special values:
    !
    !    GAMMA(0.5) = sqrt(PI)
    !
    !    For N a positive integer, GAMMA(N+1) = N!, the standard factorial.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    17 April 2001
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions,
    !    US Department of Commerce, 1964.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) N_DATA.  The user sets N_DATA to 0
    !    before the first call.  On each call, the routine increments N_DATA by 1,
    !    and returns the corresponding data; when there is no more data, the
    !    output value of N_DATA will be 0 again.
    !
    !    Output, real ( kind = 8 ) X, the argument of the function.
    !
    !    Output, real ( kind = 8 ) FX, the value of the function.
    !
    implicit none

    integer ( kind = 4 ), parameter :: n_max = 18

    real ( kind = 8 ) fx
    real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ &
        4.590845D+00,     2.218160D+00,     1.489192D+00,     1.164230D+00, &
        1.0000000000D+00, 0.9513507699D+00, 0.9181687424D+00, 0.8974706963D+00, &
        0.8872638175D+00, 0.8862269255D+00, 0.8935153493D+00, 0.9086387329D+00, &
        0.9313837710D+00, 0.9617658319D+00, 1.0000000000D+00, 3.6288000D+05, &
        1.2164510D+17,    8.8417620D+30 /)
    integer ( kind = 4 ) n_data
    real ( kind = 8 ) x
    real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ &
        0.2D+00,  0.4D+00,  0.6D+00,  0.8D+00, &
        1.0D+00,  1.1D+00,  1.2D+00,  1.3D+00, &
        1.4D+00,  1.5D+00,  1.6D+00,  1.7D+00, &
        1.8D+00,  1.9D+00,  2.0D+00, 10.0D+00, &
        20.0D+00, 30.0D+00 /)

    if ( n_data < 0 ) then
        n_data = 0
    end if

    n_data = n_data + 1

    if ( n_max < n_data ) then
        n_data = 0
        x = 0.0D+00
        fx = 0.0D+00
    else
        x = x_vec(n_data)
        fx = fx_vec(n_data)
    end if

    return
    end
    function gsumln ( a, b )

    !*****************************************************************************80
    !
    !! GSUMLN evaluates the function ln(Gamma(A + B)).
    !
    !  Discussion:
    !
    !    GSUMLN is used for 1 <= A <= 2 and 1 <= B <= 2
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, B, values whose sum is the argument of
    !    the Gamma function.
    !
    !    Output, real ( kind = 8 ) GSUMLN, the value of ln(Gamma(A+B)).
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) alnrel
    real ( kind = 8 ) b
    real ( kind = 8 ) gamma_ln1
    real ( kind = 8 ) gsumln
    real ( kind = 8 ) x

    x = a + b - 2.0D+00

    if ( x <= 0.25D+00 ) then
        gsumln = gamma_ln1 ( 1.0D+00 + x )
    else if ( x <= 1.25D+00 ) then
        gsumln = gamma_ln1 ( x ) + alnrel ( x )
    else
        gsumln = gamma_ln1 ( x - 1.0D+00 ) + log ( x * ( 1.0D+00 + x ) )
    end if

    return
    end
    function ipmpar ( i )

    !*****************************************************************************80
    !
    !! IPMPAR returns integer machine constants.
    !
    !  Discussion:
    !
    !    Input arguments 1 through 3 are queries about integer arithmetic.
    !    We assume integers are represented in the N-digit, base A form
    !
    !      sign * ( X(N-1)*A^(N-1) + ... + X(1)*A + X(0) )
    !
    !    where 0 <= X(0:N-1) < A.
    !
    !    Then:
    !
    !      IPMPAR(1) = A, the base of integer arithmetic;
    !      IPMPAR(2) = N, the number of base A digits;
    !      IPMPAR(3) = A^N - 1, the largest magnitude.
    !
    !    It is assumed that the single and real ( kind = 8 ) floating
    !    point arithmetics have the same base, say B, and that the
    !    nonzero numbers are represented in the form
    !
    !      sign * (B^E) * (X(1)/B + ... + X(M)/B^M)
    !
    !    where X(1:M) is one of { 0, 1,..., B-1 }, and 1 <= X(1) and
    !    EMIN <= E <= EMAX.
    !
    !    Input argument 4 is a query about the base of real arithmetic:
    !
    !      IPMPAR(4) = B, the base of single and real ( kind = 8 ) arithmetic.
    !
    !    Input arguments 5 through 7 are queries about single precision
    !    floating point arithmetic:
    !
    !     IPMPAR(5) = M, the number of base B digits for single precision.
    !     IPMPAR(6) = EMIN, the smallest exponent E for single precision.
    !     IPMPAR(7) = EMAX, the largest exponent E for single precision.
    !
    !    Input arguments 8 through 10 are queries about real ( kind = 8 )
    !    floating point arithmetic:
    !
    !     IPMPAR(8) = M, the number of base B digits for real ( kind = 8 ).
    !     IPMPAR(9) = EMIN, the smallest exponent E for real ( kind = 8 ).
    !     IPMPAR(10) = EMAX, the largest exponent E for real ( kind = 8 ).
    !
    !  Reference:
    !
    !    Phyllis Fox, Andrew Hall, Norman Schryer,
    !    Algorithm 528:
    !    Framework for a Portable FORTRAN Subroutine Library,
    !    ACM Transactions on Mathematical Software,
    !    Volume 4, 1978, pages 176-188.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) I, the index of the desired constant.
    !
    !    Output, integer ( kind = 4 ) IPMPAR, the value of the desired constant.
    !
    implicit none

    integer ( kind = 4 ) i
    integer ( kind = 4 ) imach(10)
    integer ( kind = 4 ) ipmpar
    !
    !     MACHINE CONSTANTS FOR AMDAHL MACHINES.
    !
    !     data imach( 1) /   2 /
    !     data imach( 2) /  31 /
    !     data imach( 3) / 2147483647 /
    !     data imach( 4) /  16 /
    !     data imach( 5) /   6 /
    !     data imach( 6) / -64 /
    !     data imach( 7) /  63 /
    !     data imach( 8) /  14 /
    !     data imach( 9) / -64 /
    !     data imach(10) /  63 /
    !
    !     Machine constants for the AT&T 3B SERIES, AT&T
    !     PC 7300, AND AT&T 6300.
    !
    !     data imach( 1) /     2 /
    !     data imach( 2) /    31 /
    !     data imach( 3) / 2147483647 /
    !     data imach( 4) /     2 /
    !     data imach( 5) /    24 /
    !     data imach( 6) /  -125 /
    !     data imach( 7) /   128 /
    !     data imach( 8) /    53 /
    !     data imach( 9) / -1021 /
    !     data imach(10) /  1024 /
    !
    !     Machine constants for the BURROUGHS 1700 SYSTEM.
    !
    !     data imach( 1) /    2 /
    !     data imach( 2) /   33 /
    !     data imach( 3) / 8589934591 /
    !     data imach( 4) /    2 /
    !     data imach( 5) /   24 /
    !     data imach( 6) / -256 /
    !     data imach( 7) /  255 /
    !     data imach( 8) /   60 /
    !     data imach( 9) / -256 /
    !     data imach(10) /  255 /
    !
    !     Machine constants for the BURROUGHS 5700 SYSTEM.
    !
    !     data imach( 1) /    2 /
    !     data imach( 2) /   39 /
    !     data imach( 3) / 549755813887 /
    !     data imach( 4) /    8 /
    !     data imach( 5) /   13 /
    !     data imach( 6) /  -50 /
    !     data imach( 7) /   76 /
    !     data imach( 8) /   26 /
    !     data imach( 9) /  -50 /
    !     data imach(10) /   76 /
    !
    !     Machine constants for the BURROUGHS 6700/7700 SYSTEMS.
    !
    !     data imach( 1) /      2 /
    !     data imach( 2) /     39 /
    !     data imach( 3) / 549755813887 /
    !     data imach( 4) /      8 /
    !     data imach( 5) /     13 /
    !     data imach( 6) /    -50 /
    !     data imach( 7) /     76 /
    !     data imach( 8) /     26 /
    !     data imach( 9) / -32754 /
    !     data imach(10) /  32780 /
    !
    !     Machine constants for the CDC 6000/7000 SERIES
    !     60 BIT ARITHMETIC, AND THE CDC CYBER 995 64 BIT
    !     ARITHMETIC (NOS OPERATING SYSTEM).
    !
    !     data imach( 1) /    2 /
    !     data imach( 2) /   48 /
    !     data imach( 3) / 281474976710655 /
    !     data imach( 4) /    2 /
    !     data imach( 5) /   48 /
    !     data imach( 6) / -974 /
    !     data imach( 7) / 1070 /
    !     data imach( 8) /   95 /
    !     data imach( 9) / -926 /
    !     data imach(10) / 1070 /
    !
    !     Machine constants for the CDC CYBER 995 64 BIT
    !     ARITHMETIC (NOS/VE OPERATING SYSTEM).
    !
    !     data imach( 1) /     2 /
    !     data imach( 2) /    63 /
    !     data imach( 3) / 9223372036854775807 /
    !     data imach( 4) /     2 /
    !     data imach( 5) /    48 /
    !     data imach( 6) / -4096 /
    !     data imach( 7) /  4095 /
    !     data imach( 8) /    96 /
    !     data imach( 9) / -4096 /
    !     data imach(10) /  4095 /
    !
    !     Machine constants for the CRAY 1, XMP, 2, AND 3.
    !
    !     data imach( 1) /     2 /
    !     data imach( 2) /    63 /
    !     data imach( 3) / 9223372036854775807 /
    !     data imach( 4) /     2 /
    !     data imach( 5) /    47 /
    !     data imach( 6) / -8189 /
    !     data imach( 7) /  8190 /
    !     data imach( 8) /    94 /
    !     data imach( 9) / -8099 /
    !     data imach(10) /  8190 /
    !
    !     Machine constants for the data GENERAL ECLIPSE S/200.
    !
    !     data imach( 1) /    2 /
    !     data imach( 2) /   15 /
    !     data imach( 3) / 32767 /
    !     data imach( 4) /   16 /
    !     data imach( 5) /    6 /
    !     data imach( 6) /  -64 /
    !     data imach( 7) /   63 /
    !     data imach( 8) /   14 /
    !     data imach( 9) /  -64 /
    !     data imach(10) /   63 /
    !
    !     Machine constants for the HARRIS 220.
    !
    !     data imach( 1) /    2 /
    !     data imach( 2) /   23 /
    !     data imach( 3) / 8388607 /
    !     data imach( 4) /    2 /
    !     data imach( 5) /   23 /
    !     data imach( 6) / -127 /
    !     data imach( 7) /  127 /
    !     data imach( 8) /   38 /
    !     data imach( 9) / -127 /
    !     data imach(10) /  127 /
    !
    !     Machine constants for the HONEYWELL 600/6000
    !     AND DPS 8/70 SERIES.
    !
    !     data imach( 1) /    2 /
    !     data imach( 2) /   35 /
    !     data imach( 3) / 34359738367 /
    !     data imach( 4) /    2 /
    !     data imach( 5) /   27 /
    !     data imach( 6) / -127 /
    !     data imach( 7) /  127 /
    !     data imach( 8) /   63 /
    !     data imach( 9) / -127 /
    !     data imach(10) /  127 /
    !
    !     Machine constants for the HP 2100
    !     3 WORD real ( kind = 8 ) OPTION WITH FTN4
    !
    !     data imach( 1) /    2 /
    !     data imach( 2) /   15 /
    !     data imach( 3) / 32767 /
    !     data imach( 4) /    2 /
    !     data imach( 5) /   23 /
    !     data imach( 6) / -128 /
    !     data imach( 7) /  127 /
    !     data imach( 8) /   39 /
    !     data imach( 9) / -128 /
    !     data imach(10) /  127 /
    !
    !     Machine constants for the HP 2100
    !     4 WORD real ( kind = 8 ) OPTION WITH FTN4
    !
    !     data imach( 1) /    2 /
    !     data imach( 2) /   15 /
    !     data imach( 3) / 32767 /
    !     data imach( 4) /    2 /
    !     data imach( 5) /   23 /
    !     data imach( 6) / -128 /
    !     data imach( 7) /  127 /
    !     data imach( 8) /   55 /
    !     data imach( 9) / -128 /
    !     data imach(10) /  127 /
    !
    !     Machine constants for the HP 9000.
    !
    !     data imach( 1) /     2 /
    !     data imach( 2) /    31 /
    !     data imach( 3) / 2147483647 /
    !     data imach( 4) /     2 /
    !     data imach( 5) /    24 /
    !     data imach( 6) /  -126 /
    !     data imach( 7) /   128 /
    !     data imach( 8) /    53 /
    !     data imach( 9) / -1021 /
    !     data imach(10) /  1024 /
    !
    !     Machine constants for the IBM 360/370 SERIES,
    !     THE ICL 2900, THE ITEL AS/6, THE XEROX SIGMA
    !     5/7/9 AND THE SEL SYSTEMS 85/86.
    !
    !     data imach( 1) /    2 /
    !     data imach( 2) /   31 /
    !     data imach( 3) / 2147483647 /
    !     data imach( 4) /   16 /
    !     data imach( 5) /    6 /
    !     data imach( 6) /  -64 /
    !     data imach( 7) /   63 /
    !     data imach( 8) /   14 /
    !     data imach( 9) /  -64 /
    !     data imach(10) /   63 /
    !
    !     Machine constants for the IBM PC.
    !
    !      data imach(1)/2/
    !      data imach(2)/31/
    !      data imach(3)/2147483647/
    !      data imach(4)/2/
    !      data imach(5)/24/
    !      data imach(6)/-125/
    !      data imach(7)/128/
    !      data imach(8)/53/
    !      data imach(9)/-1021/
    !      data imach(10)/1024/
    !
    !     Machine constants for the MACINTOSH II - ABSOFT
    !     MACFORTRAN II.
    !
    !     data imach( 1) /     2 /
    !     data imach( 2) /    31 /
    !     data imach( 3) / 2147483647 /
    !     data imach( 4) /     2 /
    !     data imach( 5) /    24 /
    !     data imach( 6) /  -125 /
    !     data imach( 7) /   128 /
    !     data imach( 8) /    53 /
    !     data imach( 9) / -1021 /
    !     data imach(10) /  1024 /
    !
    !     Machine constants for the MICROVAX - VMS FORTRAN.
    !
    !     data imach( 1) /    2 /
    !     data imach( 2) /   31 /
    !     data imach( 3) / 2147483647 /
    !     data imach( 4) /    2 /
    !     data imach( 5) /   24 /
    !     data imach( 6) / -127 /
    !     data imach( 7) /  127 /
    !     data imach( 8) /   56 /
    !     data imach( 9) / -127 /
    !     data imach(10) /  127 /
    !
    !     Machine constants for the PDP-11 FORTRAN SUPPORTING
    !     32-BIT integer ARITHMETIC.
    !
    !     data imach( 1) /    2 /
    !     data imach( 2) /   31 /
    !     data imach( 3) / 2147483647 /
    !     data imach( 4) /    2 /
    !     data imach( 5) /   24 /
    !     data imach( 6) / -127 /
    !     data imach( 7) /  127 /
    !     data imach( 8) /   56 /
    !     data imach( 9) / -127 /
    !     data imach(10) /  127 /
    !
    !     Machine constants for the SEQUENT BALANCE 8000.
    !
    !     data imach( 1) /     2 /
    !     data imach( 2) /    31 /
    !     data imach( 3) / 2147483647 /
    !     data imach( 4) /     2 /
    !     data imach( 5) /    24 /
    !     data imach( 6) /  -125 /
    !     data imach( 7) /   128 /
    !     data imach( 8) /    53 /
    !     data imach( 9) / -1021 /
    !     data imach(10) /  1024 /
    !
    !     Machine constants for the SILICON GRAPHICS IRIS-4D
    !     SERIES (MIPS R3000 PROCESSOR).
    !
    !     data imach( 1) /     2 /
    !     data imach( 2) /    31 /
    !     data imach( 3) / 2147483647 /
    !     data imach( 4) /     2 /
    !     data imach( 5) /    24 /
    !     data imach( 6) /  -125 /
    !     data imach( 7) /   128 /
    !     data imach( 8) /    53 /
    !     data imach( 9) / -1021 /
    !     data imach(10) /  1024 /
    !
    !     MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T
    !     3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T
    !     PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300).
    !
    data imach( 1) /     2 /
    data imach( 2) /    31 /
    data imach( 3) / 2147483647 /
    data imach( 4) /     2 /
    data imach( 5) /    24 /
    data imach( 6) /  -125 /
    data imach( 7) /   128 /
    data imach( 8) /    53 /
    data imach( 9) / -1021 /
    data imach(10) /  1024 /
    !
    !     Machine constants for the UNIVAC 1100 SERIES.
    !
    !     data imach( 1) /    2 /
    !     data imach( 2) /   35 /
    !     data imach( 3) / 34359738367 /
    !     data imach( 4) /    2 /
    !     data imach( 5) /   27 /
    !     data imach( 6) / -128 /
    !     data imach( 7) /  127 /
    !     data imach( 8) /   60 /
    !     data imach( 9) /-1024 /
    !     data imach(10) / 1023 /
    !
    !     Machine constants for the VAX 11/780.
    !
    !     data imach( 1) /    2 /
    !     data imach( 2) /   31 /
    !     data imach( 3) / 2147483647 /
    !     data imach( 4) /    2 /
    !     data imach( 5) /   24 /
    !     data imach( 6) / -127 /
    !     data imach( 7) /  127 /
    !     data imach( 8) /   56 /
    !     data imach( 9) / -127 /
    !     data imach(10) /  127 /
    !
    ipmpar = imach(i)

    return
    end
    subroutine negative_binomial_cdf_values ( n_data, f, s, p, cdf )

    !*****************************************************************************80
    !
    !! NEGATIVE_BINOMIAL_CDF_VALUES returns values of the negative binomial CDF.
    !
    !  Discussion:
    !
    !    Assume that a coin has a probability P of coming up heads on
    !    any one trial.  Suppose that we plan to flip the coin until we
    !    achieve a total of S heads.  If we let F represent the number of
    !    tails that occur in this process, then the value of F satisfies
    !    a negative binomial PDF:
    !
    !      PDF(F,S,P) = Choose ( F from F+S-1 ) * P**S * (1-P)**F
    !
    !    The negative binomial CDF is the probability that there are F or
    !    fewer failures upon the attainment of the S-th success.  Thus,
    !
    !      CDF(F,S,P) = sum ( 0 <= G <= F ) PDF(G,S,P)
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    07 June 2004
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    FC Powell,
    !    Statistical Tables for Sociology, Biology and Physical Sciences,
    !    Cambridge University Press, 1982.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) N_DATA.  The user sets N_DATA to 0
    !    before the first call.  On each call, the routine increments N_DATA by 1,
    !    and returns the corresponding data; when there is no more data, the
    !    output value of N_DATA will be 0 again.
    !
    !    Output, integer ( kind = 4 ) F, the maximum number of failures.
    !
    !    Output, integer ( kind = 4 ) S, the number of successes.
    !
    !    Output, real ( kind = 8 ) P, the probability of a success on one trial.
    !
    !    Output, real ( kind = 8 ) CDF, the probability of at most F failures
    !    before the S-th success.
    !
    implicit none

    integer ( kind = 4 ), parameter :: n_max = 27

    real ( kind = 8 ) cdf
    real ( kind = 8 ), save, dimension ( n_max ) :: cdf_vec = (/ &
        0.6367D+00, 0.3633D+00, 0.1445D+00, &
        0.5000D+00, 0.2266D+00, 0.0625D+00, &
        0.3438D+00, 0.1094D+00, 0.0156D+00, &
        0.1792D+00, 0.0410D+00, 0.0041D+00, &
        0.0705D+00, 0.0109D+00, 0.0007D+00, &
        0.9862D+00, 0.9150D+00, 0.7472D+00, &
        0.8499D+00, 0.5497D+00, 0.2662D+00, &
        0.6513D+00, 0.2639D+00, 0.0702D+00, &
        1.0000D+00, 0.0199D+00, 0.0001D+00 /)
    integer ( kind = 4 ) f
    integer ( kind = 4 ), save, dimension ( n_max ) :: f_vec = (/ &
        4,  3,  2, &
        3,  2,  1, &
        2,  1,  0, &
        2,  1,  0, &
        2,  1,  0, &
        11, 10,  9, &
        17, 16, 15, &
        9,  8,  7, &
        2,  1,  0 /)
    integer ( kind = 4 ) n_data
    real ( kind = 8 ) p
    real ( kind = 8 ), save, dimension ( n_max ) :: p_vec = (/ &
        0.50D+00, 0.50D+00, 0.50D+00, &
        0.50D+00, 0.50D+00, 0.50D+00, &
        0.50D+00, 0.50D+00, 0.50D+00, &
        0.40D+00, 0.40D+00, 0.40D+00, &
        0.30D+00, 0.30D+00, 0.30D+00, &
        0.30D+00, 0.30D+00, 0.30D+00, &
        0.10D+00, 0.10D+00, 0.10D+00, &
        0.10D+00, 0.10D+00, 0.10D+00, &
        0.01D+00, 0.01D+00, 0.01D+00 /)
    integer ( kind = 4 ) s
    integer ( kind = 4 ), save, dimension ( n_max ) :: s_vec = (/ &
        4, 5, 6, &
        4, 5, 6, &
        4, 5, 6, &
        4, 5, 6, &
        4, 5, 6, &
        1, 2, 3, &
        1, 2, 3, &
        1, 2, 3, &
        0, 1, 2 /)

    if ( n_data < 0 ) then
        n_data = 0
    end if

    n_data = n_data + 1

    if ( n_max < n_data ) then
        n_data = 0
        f = 0
        s = 0
        p = 0.0D+00
        cdf = 0.0D+00
    else
        f = f_vec(n_data)
        s = s_vec(n_data)
        p = p_vec(n_data)
        cdf = cdf_vec(n_data)
    end if

    return
    end
    subroutine normal_01_cdf_values ( n_data, x, fx )

    !*****************************************************************************80
    !
    !! NORMAL_01_CDF_VALUES returns some values of the Normal 01 CDF.
    !
    !  Discussion:
    !
    !    In Mathematica, the function can be evaluated by:
    !
    !      Needs["Statistics`ContinuousDistributions`"]
    !      dist = NormalDistribution [ 0, 1 ]
    !      CDF [ dist, x ]
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    28 August 2004
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions,
    !    US Department of Commerce, 1964.
    !
    !    Stephen Wolfram,
    !    The Mathematica Book,
    !    Fourth Edition,
    !    Wolfram Media / Cambridge University Press, 1999.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) N_DATA.  The user sets N_DATA to 0
    !    before the first call.  On each call, the routine increments N_DATA by 1,
    !    and returns the corresponding data; when there is no more data, the
    !    output value of N_DATA will be 0 again.
    !
    !    Output, real ( kind = 8 ) X, the argument of the function.
    !
    !    Output, real ( kind = 8 ) FX, the value of the function.
    !
    implicit none

    integer ( kind = 4 ), parameter :: n_max = 17

    real ( kind = 8 ) fx
    real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ &
        0.5000000000000000D+00, &
        0.5398278372770290D+00, &
        0.5792597094391030D+00, &
        0.6179114221889526D+00, &
        0.6554217416103242D+00, &
        0.6914624612740131D+00, &
        0.7257468822499270D+00, &
        0.7580363477769270D+00, &
        0.7881446014166033D+00, &
        0.8159398746532405D+00, &
        0.8413447460685429D+00, &
        0.9331927987311419D+00, &
        0.9772498680518208D+00, &
        0.9937903346742239D+00, &
        0.9986501019683699D+00, &
        0.9997673709209645D+00, &
        0.9999683287581669D+00 /)
    integer ( kind = 4 ) n_data
    real ( kind = 8 ) x
    real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ &
        0.0000000000000000D+00, &
        0.1000000000000000D+00, &
        0.2000000000000000D+00, &
        0.3000000000000000D+00, &
        0.4000000000000000D+00, &
        0.5000000000000000D+00, &
        0.6000000000000000D+00, &
        0.7000000000000000D+00, &
        0.8000000000000000D+00, &
        0.9000000000000000D+00, &
        0.1000000000000000D+01, &
        0.1500000000000000D+01, &
        0.2000000000000000D+01, &
        0.2500000000000000D+01, &
        0.3000000000000000D+01, &
        0.3500000000000000D+01, &
        0.4000000000000000D+01 /)

    if ( n_data < 0 ) then
        n_data = 0
    end if

    n_data = n_data + 1

    if ( n_max < n_data ) then
        n_data = 0
        x = 0.0D+00
        fx = 0.0D+00
    else
        x = x_vec(n_data)
        fx = fx_vec(n_data)
    end if

    return
    end
    subroutine normal_cdf_values ( n_data, mu, sigma, x, fx )

    !*****************************************************************************80
    !
    !! NORMAL_CDF_VALUES returns some values of the Normal CDF.
    !
    !  Discussion:
    !
    !    In Mathematica, the function can be evaluated by:
    !
    !      Needs["Statistics`ContinuousDistributions`"]
    !      dist = NormalDistribution [ mu, sigma ]
    !      CDF [ dist, x ]
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    05 August 2004
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions,
    !    US Department of Commerce, 1964.
    !
    !    Stephen Wolfram,
    !    The Mathematica Book,
    !    Fourth Edition,
    !    Wolfram Media / Cambridge University Press, 1999.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) N_DATA.  The user sets N_DATA to 0
    !    before the first call.  On each call, the routine increments N_DATA by 1,
    !    and returns the corresponding data; when there is no more data, the
    !    output value of N_DATA will be 0 again.
    !
    !    Output, real ( kind = 8 ) MU, the mean of the distribution.
    !
    !    Output, real ( kind = 8 ) SIGMA, the variance of the distribution.
    !
    !    Output, real ( kind = 8 ) X, the argument of the function.
    !
    !    Output, real ( kind = 8 ) FX, the value of the function.
    !
    implicit none

    integer ( kind = 4 ), parameter :: n_max = 12

    real ( kind = 8 ) fx
    real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ &
        0.5000000000000000D+00, &
        0.9772498680518208D+00, &
        0.9999683287581669D+00, &
        0.9999999990134124D+00, &
        0.6914624612740131D+00, &
        0.6305586598182364D+00, &
        0.5987063256829237D+00, &
        0.5792597094391030D+00, &
        0.6914624612740131D+00, &
        0.5000000000000000D+00, &
        0.3085375387259869D+00, &
        0.1586552539314571D+00 /)
    real ( kind = 8 ) mu
    real ( kind = 8 ), save, dimension ( n_max ) :: mu_vec = (/ &
        0.1000000000000000D+01, &
        0.1000000000000000D+01, &
        0.1000000000000000D+01, &
        0.1000000000000000D+01, &
        0.1000000000000000D+01, &
        0.1000000000000000D+01, &
        0.1000000000000000D+01, &
        0.1000000000000000D+01, &
        0.2000000000000000D+01, &
        0.3000000000000000D+01, &
        0.4000000000000000D+01, &
        0.5000000000000000D+01 /)
    integer ( kind = 4 ) n_data
    real ( kind = 8 ) sigma
    real ( kind = 8 ), save, dimension ( n_max ) :: sigma_vec = (/ &
        0.5000000000000000D+00, &
        0.5000000000000000D+00, &
        0.5000000000000000D+00, &
        0.5000000000000000D+00, &
        0.2000000000000000D+01, &
        0.3000000000000000D+01, &
        0.4000000000000000D+01, &
        0.5000000000000000D+01, &
        0.2000000000000000D+01, &
        0.2000000000000000D+01, &
        0.2000000000000000D+01, &
        0.2000000000000000D+01 /)
    real ( kind = 8 ) x
    real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ &
        0.1000000000000000D+01, &
        0.2000000000000000D+01, &
        0.3000000000000000D+01, &
        0.4000000000000000D+01, &
        0.2000000000000000D+01, &
        0.2000000000000000D+01, &
        0.2000000000000000D+01, &
        0.2000000000000000D+01, &
        0.3000000000000000D+01, &
        0.3000000000000000D+01, &
        0.3000000000000000D+01, &
        0.3000000000000000D+01 /)

    if ( n_data < 0 ) then
        n_data = 0
    end if

    n_data = n_data + 1

    if ( n_max < n_data ) then
        n_data = 0
        mu = 0.0D+00
        sigma = 0.0D+00
        x = 0.0D+00
        fx = 0.0D+00
    else
        mu = mu_vec(n_data)
        sigma = sigma_vec(n_data)
        x = x_vec(n_data)
        fx = fx_vec(n_data)
    end if

    return
    end
    subroutine poisson_cdf_values ( n_data, a, x, fx )

    !*****************************************************************************80
    !
    !! POISSON_CDF_VALUES returns some values of the Poisson CDF.
    !
    !  Discussion:
    !
    !    CDF(X)(A) is the probability of at most X successes in unit time,
    !    given that the expected mean number of successes is A.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    28 May 2001
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions,
    !    US Department of Commerce, 1964.
    !
    !    Daniel Zwillinger,
    !    CRC Standard Mathematical Tables and Formulae,
    !    30th Edition, CRC Press, 1996, pages 653-658.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) N_DATA.  The user sets N_DATA to 0
    !    before the first call.  On each call, the routine increments N_DATA by 1,
    !    and returns the corresponding data; when there is no more data, the
    !    output value of N_DATA will be 0 again.
    !
    !    Output, real ( kind = 8 ) A, integer X, the arguments of the function.
    !
    !    Output, real ( kind = 8 ) FX, the value of the function.
    !
    implicit none

    integer ( kind = 4 ), parameter :: n_max = 21

    real ( kind = 8 ) a
    real ( kind = 8 ), save, dimension ( n_max ) :: a_vec = (/ &
        0.02D+00, 0.10D+00, 0.10D+00, 0.50D+00, &
        0.50D+00, 0.50D+00, 1.00D+00, 1.00D+00, &
        1.00D+00, 1.00D+00, 2.00D+00, 2.00D+00, &
        2.00D+00, 2.00D+00, 5.00D+00, 5.00D+00, &
        5.00D+00, 5.00D+00, 5.00D+00, 5.00D+00, &
        5.00D+00 /)
    real ( kind = 8 ) fx
    real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ &
        0.980D+00, 0.905D+00, 0.995D+00, 0.607D+00, &
        0.910D+00, 0.986D+00, 0.368D+00, 0.736D+00, &
        0.920D+00, 0.981D+00, 0.135D+00, 0.406D+00, &
        0.677D+00, 0.857D+00, 0.007D+00, 0.040D+00, &
        0.125D+00, 0.265D+00, 0.441D+00, 0.616D+00, &
        0.762D+00 /)
    integer ( kind = 4 ) n_data
    integer ( kind = 4 ) x
    integer ( kind = 4 ), save, dimension ( n_max ) :: x_vec = (/ &
        0, 0, 1, 0, &
        1, 2, 0, 1, &
        2, 3, 0, 1, &
        2, 3, 0, 1, &
        2, 3, 4, 5, &
        6 /)

    if ( n_data < 0 ) then
        n_data = 0
    end if

    n_data = n_data + 1

    if ( n_max < n_data ) then
        n_data = 0
        a = 0.0D+00
        x = 0
        fx = 0.0D+00
    else
        a = a_vec(n_data)
        x = x_vec(n_data)
        fx = fx_vec(n_data)
    end if

    return
    end
    function psi ( xx )

    !*****************************************************************************80
    !
    !! PSI evaluates the psi or digamma function, d/dx ln(gamma(x)).
    !
    !  Discussion:
    !
    !    The main computation involves evaluation of rational Chebyshev
    !    approximations.  PSI was written at Argonne National Laboratory
    !    for FUNPACK, and subsequently modified by A. H. Morris of NSWC.
    !
    !  Reference:
    !
    !    William Cody, Anthony Strecok, Henry Thacher,
    !    Chebyshev Approximations for the Psi Function,
    !    Mathematics of Computation,
    !    Volume 27, 1973, pages 123-127.
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) XX, the argument of the psi function.
    !
    !    Output, real ( kind = 8 ) PSI, the value of the psi function.  PSI
    !    is assigned the value 0 when the psi function is undefined.
    !
    implicit none

    real ( kind = 8 ) aug
    real ( kind = 8 ) den
    real ( kind = 8 ), parameter :: dx0 = &
        1.461632144968362341262659542325721325D+00
    integer ( kind = 4 ) i
    integer ( kind = 4 ) ipmpar
    integer ( kind = 4 ) m
    integer ( kind = 4 ) n
    integer ( kind = 4 ) nq
    real ( kind = 8 ), parameter, dimension ( 7 ) :: p1 = (/ &
        0.895385022981970D-02, &
        0.477762828042627D+01, &
        0.142441585084029D+03, &
        0.118645200713425D+04, &
        0.363351846806499D+04, &
        0.413810161269013D+04, &
        0.130560269827897D+04/)
    real ( kind = 8 ), dimension ( 4 ) :: p2 = (/ &
        -0.212940445131011D+01, &
        -0.701677227766759D+01, &
        -0.448616543918019D+01, &
        -0.648157123766197D+00 /)
    real ( kind = 8 ), parameter :: piov4 = 0.785398163397448D+00
    real ( kind = 8 ) psi
    !
    !  Coefficients for rational approximation of
    !  PSI(X) / (X - X0),  0.5D+00 <= X <= 3.0D+00
    !
    real ( kind = 8 ), dimension ( 6 ) :: q1 = (/ &
        0.448452573429826D+02, &
        0.520752771467162D+03, &
        0.221000799247830D+04, &
        0.364127349079381D+04, &
        0.190831076596300D+04, &
        0.691091682714533D-05 /)
    real ( kind = 8 ), dimension ( 4 ) :: q2 = (/ &
        0.322703493791143D+02, &
        0.892920700481861D+02, &
        0.546117738103215D+02, &
        0.777788548522962D+01 /)
    real ( kind = 8 ) sgn
    real ( kind = 8 ) upper
    real ( kind = 8 ) w
    real ( kind = 8 ) x
    real ( kind = 8 ) xmax1
    real ( kind = 8 ) xmx0
    real ( kind = 8 ) xsmall
    real ( kind = 8 ) xx
    real ( kind = 8 ) z
    !
    !  XMAX1 is the largest positive floating point constant with entirely
    !  integer representation.  It is also used as negative of lower bound
    !  on acceptable negative arguments and as the positive argument beyond which
    !  psi may be represented as LOG(X).
    !
    xmax1 = real ( ipmpar(3), kind = 8 )
    xmax1 = min ( xmax1, 1.0D+00 / epsilon ( xmax1 ) )
    !
    !  XSMALL is the absolute argument below which PI*COTAN(PI*X)
    !  may be represented by 1/X.
    !
    xsmall = 1.0D-09

    x = xx
    aug = 0.0D+00

    if ( x == 0.0D+00 ) then
        psi = 0.0D+00
        return
    end if
    !
    !  X < 0.5,  Use reflection formula PSI(1-X) = PSI(X) + PI * COTAN(PI*X)
    !
    if ( x < 0.5D+00 ) then
        !
        !  0 < ABS ( X ) <= XSMALL.  Use 1/X as a substitute for PI*COTAN(PI*X)
        !
        if ( abs ( x ) <= xsmall ) then
            aug = -1.0D+00 / x
            go to 40
        end if
        !
        !  Reduction of argument for cotangent.
        !
        w = -x
        sgn = piov4

        if ( w <= 0.0D+00 ) then
            w = -w
            sgn = -sgn
        end if
        !
        !  Make an error exit if X <= -XMAX1
        !
        if ( xmax1 <= w ) then
            psi = 0.0D+00
            return
        end if

        nq = int ( w )
        w = w - real ( nq, kind = 8 )
        nq = int ( w * 4.0D+00 )
        w = 4.0D+00 * ( w - real ( nq, kind = 8 ) * 0.25D+00 )
        !
        !  W is now related to the fractional part of 4.0D+00 * X.
        !  Adjust argument to correspond to values in first
        !  quadrant and determine sign.
        !
        n = nq / 2
        if ( n + n /= nq ) then
            w = 1.0D+00 - w
        end if

        z = piov4 * w
        m = n / 2

        if ( m + m /= n ) then
            sgn = -sgn
        end if
        !
        !  Determine final value for -PI * COTAN(PI*X).
        !
        n = ( nq + 1 ) / 2
        m = n / 2
        m = m + m

        if ( m == n ) then

            if ( z == 0.0D+00 ) then
                psi = 0.0D+00
                return
            end if

            aug = 4.0D+00 * sgn * ( cos(z) / sin(z) )

        else

            aug = 4.0D+00 * sgn * ( sin(z) / cos(z) )

        end if

40      continue

        x = 1.0D+00 - x

    end if
    !
    !  0.5 <= X <= 3
    !
    if ( x <= 3.0D+00 ) then

        den = x
        upper = p1(1) * x

        do i = 1, 5
            den = ( den + q1(i) ) * x
            upper = ( upper + p1(i+1) ) * x
        end do

        den = ( upper + p1(7) ) / ( den + q1(6) )
        xmx0 = real ( x, kind = 8 ) - dx0
        psi = den * xmx0 + aug
        !
        !  3 < X < XMAX1
        !
    else if ( x < xmax1 ) then

        w = 1.0D+00 / x**2
        den = w
        upper = p2(1) * w

        do i = 1, 3
            den = ( den + q2(i) ) * w
            upper = ( upper + p2(i+1) ) * w
        end do

        aug = upper / ( den + q2(4) ) - 0.5D+00 / x + aug
        psi = aug + log ( x )
        !
        !  XMAX1 <= X
        !
    else

        psi = aug + log ( x )

    end if

    return
    end
    subroutine psi_values ( n_data, x, fx )

    !*****************************************************************************80
    !
    !! PSI_VALUES returns some values of the Psi or Digamma function.
    !
    !  Discussion:
    !
    !    PSI(X) = d LN ( GAMMA ( X ) ) / d X = GAMMA'(X) / GAMMA(X)
    !
    !    PSI(1) = - Euler's constant.
    !
    !    PSI(X+1) = PSI(X) + 1 / X.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    17 May 2001
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions,
    !    US Department of Commerce, 1964.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) N_DATA.  The user sets N_DATA to 0
    !    before the first call.  On each call, the routine increments N_DATA by 1,
    !    and returns the corresponding data; when there is no more data, the
    !    output value of N_DATA will be 0 again.
    !
    !    Output, real ( kind = 8 ) X, the argument of the function.
    !
    !    Output, real ( kind = 8 ) FX, the value of the function.
    !
    implicit none

    integer ( kind = 4 ), parameter :: n_max = 11

    real ( kind = 8 ) fx
    real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ &
        -0.5772156649D+00, -0.4237549404D+00, -0.2890398966D+00, &
        -0.1691908889D+00, -0.0613845446D+00, -0.0364899740D+00, &
        0.1260474528D+00,  0.2085478749D+00,  0.2849914333D+00, &
        0.3561841612D+00,  0.4227843351D+00 /)
    integer ( kind = 4 ) n_data
    real ( kind = 8 ) x
    real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ &
        1.0D+00,  1.1D+00,  1.2D+00,  &
        1.3D+00,  1.4D+00,  1.5D+00,  &
        1.6D+00,  1.7D+00,  1.8D+00,  &
        1.9D+00,  2.0D+00 /)

    if ( n_data < 0 ) then
        n_data = 0
    end if

    n_data = n_data + 1

    if ( n_max < n_data ) then
        n_data = 0
        x = 0.0D+00
        fx = 0.0D+00
    else
        x = x_vec(n_data)
        fx = fx_vec(n_data)
    end if

    return
    end
    subroutine r8_swap ( x, y )

    !*****************************************************************************80
    !
    !! R8_SWAP swaps two R8 values.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    01 May 2000
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input/output, real ( kind = 8 ) X, Y.  On output, the values of X and
    !    Y have been interchanged.
    !
    implicit none

    real ( kind = 8 ) x
    real ( kind = 8 ) y
    real ( kind = 8 ) z

    z = x
    x = y
    y = z

    return
    end
    function rcomp ( a, x )

    !*****************************************************************************80
    !
    !! RCOMP evaluates exp(-X) * X**A / Gamma(A).
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A, X, arguments of the quantity to be computed.
    !
    !    Output, real ( kind = 8 ) RCOMP, the value of exp(-X) * X**A / Gamma(A).
    !
    !  Local parameters:
    !
    !    RT2PIN = 1/SQRT(2*PI)
    !
    implicit none

    real ( kind = 8 ) a
    real ( kind = 8 ) gam1
    real ( kind = 8 ) gamma
    real ( kind = 8 ) rcomp
    real ( kind = 8 ) rlog
    real ( kind = 8 ), parameter :: rt2pin = 0.398942280401433D+00
    real ( kind = 8 ) t
    real ( kind = 8 ) t1
    real ( kind = 8 ) u
    real ( kind = 8 ) x

    if ( a < 20.0D+00 ) then

        t = a * log ( x ) - x

        if ( a < 1.0D+00 ) then
            rcomp = ( a * exp ( t ) ) * ( 1.0D+00 + gam1 ( a ) )
        else
            rcomp = exp ( t ) / gamma ( a )
        end if

    else

        u = x / a

        if ( u == 0.0D+00 ) then
            rcomp = 0.0D+00
        else
            t = ( 1.0D+00 / a )**2
            t1 = ((( 0.75D+00 * t - 1.0D+00 ) * t + 3.5D+00 ) * t - 105.0D+00 ) &
                / ( a * 1260.0D+00 )
            t1 = t1 - a * rlog ( u )
            rcomp = rt2pin * sqrt ( a ) * exp ( t1 )
        end if

    end if

    return
    end
    function rexp ( x )

    !*****************************************************************************80
    !
    !! REXP evaluates the function EXP(X) - 1.
    !
    !  Modified:
    !
    !    09 December 1999
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) X, the argument of the function.
    !
    !    Output, real ( kind = 8 ) REXP, the value of EXP(X)-1.
    !
    implicit none

    real ( kind = 8 ), parameter :: p1 =  0.914041914819518D-09
    real ( kind = 8 ), parameter :: p2 =  0.238082361044469D-01
    real ( kind = 8 ), parameter :: q1 = -0.499999999085958D+00
    real ( kind = 8 ), parameter :: q2 =  0.107141568980644D+00
    real ( kind = 8 ), parameter :: q3 = -0.119041179760821D-01
    real ( kind = 8 ), parameter :: q4 =  0.595130811860248D-03
    real ( kind = 8 ) rexp
    real ( kind = 8 ) w
    real ( kind = 8 ) x

    if ( abs ( x ) <= 0.15D+00 ) then

        rexp = x * ( ( ( p2 * x + p1 ) * x + 1.0D+00 ) &
            / ( ( ( ( q4 * x + q3 ) * x + q2 ) * x + q1 ) * x + 1.0D+00 ) )

    else

        w = exp ( x )

        if ( x <= 0.0D+00 ) then
            rexp = ( w - 0.5D+00 ) - 0.5D+00
        else
            rexp = w * ( 0.5D+00 + ( 0.5D+00 - 1.0D+00 / w ) )
        end if

    end if

    return
    end
    function rlog ( x )

    !*****************************************************************************80
    !
    !! RLOG computes X - 1 - LN(X).
    !
    !  Modified:
    !
    !    06 August 2004
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) X, the argument of the function.
    !
    !    Output, real ( kind = 8 ) RLOG, the value of the function.
    !
    implicit none

    real ( kind = 8 ), parameter :: a  =  0.566749439387324D-01
    real ( kind = 8 ), parameter :: b  =  0.456512608815524D-01
    real ( kind = 8 ), parameter :: half = 0.5D+00
    real ( kind = 8 ), parameter :: p0 =  0.333333333333333D+00
    real ( kind = 8 ), parameter :: p1 = -0.224696413112536D+00
    real ( kind = 8 ), parameter :: p2 =  0.620886815375787D-02
    real ( kind = 8 ), parameter :: q1 = -0.127408923933623D+01
    real ( kind = 8 ), parameter :: q2 =  0.354508718369557D+00
    real ( kind = 8 ) r
    real ( kind = 8 ) rlog
    real ( kind = 8 ) t
    real ( kind = 8 ), parameter :: two =  2.0D+00
    real ( kind = 8 ) u
    real ( kind = 8 ) w
    real ( kind = 8 ) w1
    real ( kind = 8 ) x

    if ( x < 0.61D+00 ) then

        r = ( x - 0.5D+00 ) - 0.5D+00
        rlog = r - log ( x )

    else if ( x < 1.57D+00 ) then

        if ( x < 0.82D+00 ) then

            u = x - 0.7D+00
            u = u / 0.7D+00
            w1 = a - u * 0.3D+00

        else if ( x < 1.18D+00 ) then

            u = ( x - half ) - half
            w1 = 0.0D+00

        else if ( x < 1.57D+00 ) then

            u = 0.75D+00 * x - 1.0D+00
            w1 = b + u / 3.0D+00

        end if

        r = u / ( u + two )
        t = r * r
        w = ( ( p2 * t + p1 ) * t + p0 ) / ( ( q2 * t + q1 ) * t + 1.0D+00 )
        rlog = two * t * ( 1.0D+00 / ( 1.0D+00 - r ) - r * w ) + w1

    else if ( 1.57D+00 <= x ) then

        r = ( x - half ) - half
        rlog = r - log ( x )

    end if

    return
    end
    function rlog1 ( x )

    !*****************************************************************************80
    !
    !! RLOG1 evaluates the function X - ln ( 1 + X ).
    !
    !  Author:
    !
    !    Armido DiDinato, Alfred Morris
    !
    !  Reference:
    !
    !    Armido DiDinato, Alfred Morris,
    !    Algorithm 708:
    !    Significant Digit Computation of the Incomplete Beta Function Ratios,
    !    ACM Transactions on Mathematical Software,
    !    Volume 18, 1993, pages 360-373.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) X, the argument.
    !
    !    Output, real ( kind = 8 ) RLOG1, the value of X - ln ( 1 + X ).
    !
    implicit none

    real ( kind = 8 ), parameter :: a = 0.566749439387324D-01
    real ( kind = 8 ), parameter :: b = 0.456512608815524D-01
    real ( kind = 8 ) h
    real ( kind = 8 ), parameter :: half = 0.5D+00
    real ( kind = 8 ), parameter :: p0 = 0.333333333333333D+00
    real ( kind = 8 ), parameter :: p1 = -0.224696413112536D+00
    real ( kind = 8 ), parameter :: p2 = 0.620886815375787D-02
    real ( kind = 8 ), parameter :: q1 = -0.127408923933623D+01
    real ( kind = 8 ), parameter :: q2 = 0.354508718369557D+00
    real ( kind = 8 ) r
    real ( kind = 8 ) rlog1
    real ( kind = 8 ) t
    real ( kind = 8 ), parameter :: two =  2.0D+00
    real ( kind = 8 ) w
    real ( kind = 8 ) w1
    real ( kind = 8 ) x

    if ( x < -0.39D+00 ) then

        w = ( x + half ) + half
        rlog1 = x - log ( w )

    else if ( x < -0.18D+00 ) then

        h = x + 0.3D+00
        h = h / 0.7D+00
        w1 = a - h * 0.3D+00

        r = h / ( h + 2.0D+00 )
        t = r * r
        w = ( ( p2 * t + p1 ) * t + p0 ) / ( ( q2 * t + q1 ) * t + 1.0D+00 )
        rlog1 = two * t * ( 1.0D+00 / ( 1.0D+00 - r ) - r * w ) + w1

    else if ( x <= 0.18D+00 ) then

        h = x
        w1 = 0.0D+00

        r = h / ( h + two )
        t = r * r
        w = ( ( p2 * t + p1 ) * t + p0 ) / ( ( q2 * t + q1 ) * t + 1.0D+00 )
        rlog1 = two * t * ( 1.0D+00 / ( 1.0D+00 - r ) - r * w ) + w1

    else if ( x <= 0.57D+00 ) then

        h = 0.75D+00 * x - 0.25D+00
        w1 = b + h / 3.0D+00

        r = h / ( h + 2.0D+00 )
        t = r * r
        w = ( ( p2 * t + p1 ) * t + p0 ) / ( ( q2 * t + q1 ) * t + 1.0D+00 )
        rlog1 = two * t * ( 1.0D+00 / ( 1.0D+00 - r ) - r * w ) + w1

    else

        w = ( x + half ) + half
        rlog1 = x - log ( w )

    end if

    return
    end
    subroutine student_cdf_values ( n_data, a, x, fx )

    !*****************************************************************************80
    !
    !! STUDENT_CDF_VALUES returns some values of the Student CDF.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    02 June 2001
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions,
    !    US Department of Commerce, 1964.
    !
    !  Parameters:
    !
    !    Input/output, integer ( kind = 4 ) N_DATA.  The user sets N_DATA to 0
    !    before the first call.  On each call, the routine increments N_DATA by 1,
    !    and returns the corresponding data; when there is no more data, the
    !    output value of N_DATA will be 0 again.
    !
    !    Output, integer ( kind = 4 ) A, real ( kind = 8 ) X, the arguments of
    !    the function.
    !
    !    Output, real ( kind = 8 ) FX, the value of the function.
    !
    implicit none

    integer ( kind = 4 ), parameter :: n_max = 13

    integer ( kind = 4 ) a
    integer ( kind = 4 ), save, dimension ( n_max ) :: a_vec = (/ &
        1, 2, 3, 4, &
        5, 2, 5, 2, &
        5, 2, 3, 4, &
        5 /)
    real ( kind = 8 ) fx
    real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ &
        0.60D+00, 0.60D+00, 0.60D+00, 0.60D+00, &
        0.60D+00, 0.75D+00, 0.75D+00, 0.95D+00, &
        0.95D+00, 0.99D+00, 0.99D+00, 0.99D+00, &
        0.99D+00 /)
    integer ( kind = 4 ) n_data
    real ( kind = 8 ) x
    real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ &
        0.325D+00, 0.289D+00, 0.277D+00, 0.271D+00, &
        0.267D+00, 0.816D+00, 0.727D+00, 2.920D+00, &
        2.015D+00, 6.965D+00, 4.541D+00, 3.747D+00, &
        3.365D+00 /)

    if ( n_data < 0 ) then
        n_data = 0
    end if

    n_data = n_data + 1

    if ( n_max < n_data ) then
        n_data = 0
        a = 0
        x = 0.0D+00
        fx = 0.0D+00
    else
        a = a_vec(n_data)
        x = x_vec(n_data)
        fx = fx_vec(n_data)
    end if

    return
    end
    function stvaln ( p )

    !*****************************************************************************80
    !
    !! STVALN provides starting values for the inverse of the normal distribution.
    !
    !  Discussion:
    !
    !    The routine returns an X for which it is approximately true that
    !      P = CUMNOR(X),
    !    that is,
    !      P = Integral ( -infinity < U <= X ) exp(-U*U/2)/sqrt(2*PI) dU.
    !
    !  Reference:
    !
    !    William Kennedy, James Gentle,
    !    Statistical Computing,
    !    Marcel Dekker, NY, 1980, page 95,
    !    QA276.4 K46
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) P, the probability whose normal deviate
    !    is sought.
    !
    !    Output, real ( kind = 8 ) STVALN, the normal deviate whose probability
    !    is approximately P.
    !
    implicit none

    real ( kind = 8 ) eval_pol
    real ( kind = 8 ) p
    real ( kind = 8 ) sgn
    real ( kind = 8 ) stvaln
    real ( kind = 8 ), parameter, dimension(0:4) :: xden = (/ &
        0.993484626060D-01, &
        0.588581570495D+00, &
        0.531103462366D+00, &
        0.103537752850D+00, &
        0.38560700634D-02 /)
    real ( kind = 8 ), parameter, dimension(0:4) :: xnum = (/ &
        -0.322232431088D+00, &
        -1.000000000000D+00, &
        -0.342242088547D+00, &
        -0.204231210245D-01, &
        -0.453642210148D-04 /)
    real ( kind = 8 ) y
    real ( kind = 8 ) z

    if ( p <= 0.5D+00 ) then

        sgn = -1.0D+00
        z = p

    else

        sgn = 1.0D+00
        z = 1.0D+00 - p

    end if

    y = sqrt ( -2.0D+00 * log ( z ) )
    stvaln = y + eval_pol ( xnum, 4, y ) / eval_pol ( xden, 4, y )
    stvaln = sgn * stvaln

    return
    end
